home *** CD-ROM | disk | FTP | other *** search
/ Programmer Power Tools / Programmer Power Tools.iso / progjrn / pj_6_6.arc / FCODE.ARC / UPDATE.FOR < prev   
Text File  |  1987-11-12  |  62KB  |  1,890 lines
  1.  
  2.       PROGRAM  UPDATE
  3. C
  4. C     Revision Author:   M. Steven Baker
  5. C     Revision Date:     August 11, 1986
  6. C
  7. C     Revised for RM Fortan on PC
  8. C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>  COMPILER DEPENDENT
  9. C---
  10. C---          ENDER ERDEM          LAWRENCE BERKELEY LABORATORY  1981
  11. C---
  12.       IMPLICIT INTEGER (A-Z)
  13. C---
  14.       COMMON /CARD/   CARD(80), JCARD, LINCNT, PRTFLG, ICH
  15.      1               ,IFL(8)  , BKSPFL
  16.       COMMON /FILES/  INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
  17.      1              , EDTT  , PL1TMP, PL2TMP, PLTMP , PLIN
  18.       COMMON /FLAGS/  FULFLG, RESEQF, PRECOF, NPLFLG, ERRFLG
  19.      9              , WARNFL, SHOWFL
  20. C---
  21.       OPEN( UNIT=INPUT , FILE='INPUT.TMP' , STATUS='old' )
  22.       OPEN( UNIT=OUTPUT, FILE='OUTPUT.'   , STATUS='UNKNOWN')
  23. C    .                                    , ACCESS='APPEND' )
  24.       OPEN( UNIT=OLDPL , FILE='OLDPL.TMP' , STATUS='UNKNOWN' )
  25.       OPEN( UNIT=NEWPL , FILE='NEWPL.TMP' , STATUS='UNKNOWN' )
  26.       OPEN( UNIT=COMPIL, FILE='COMPIL.TMP', STATUS='UNKNOWN' )
  27.       OPEN( UNIT=EDTT  , FILE='EDTT.TMP'  , STATUS='UNKNOWN' )
  28. C    .                                    , FORM='UNFORMATTED' )
  29.       OPEN( UNIT=PL1TMP, FILE='PL1TMP.TMP', STATUS='UNKNOWN' )
  30. C    .                 , buffercount=8    , dispose='delete' )
  31.       OPEN( UNIT=PL2TMP, FILE='PL2TMP.TMP', STATUS='UNKNOWN' )
  32. C    .                 , buffercount=8    , dispose='delete' )
  33.       PLTMP = PL1TMP
  34. C------ CK OLDPL
  35.       REWIND  OLDPL
  36. C>>>>>>>> *EOF* <<<<<<<<
  37.       READ( OLDPL, 1001, END=200 )
  38. 1001  FORMAT( 20A4 )
  39.         GOTO  300
  40. C------ CREATION RUN .
  41. 200   WRITE(OUTPUT,1011)
  42. 1011  FORMAT(46H1U P D A T E   C R E A T I O N   L I S T I N G//)
  43.        CALL  CREATE ( PLTMP, ERRCRT )
  44.       GOTO  500
  45. C------ UPDATE RUN .
  46. 300   WRITE(OUTPUT,1012)
  47. 1012  FORMAT(50H1U P D A T E   C O R R E C T I O N   L I S T I N G//)
  48.       PLIN = OLDPL
  49.        CALL  OPLRD
  50. 400    CALL  CORRD
  51.       IF( ERRFLG .NE. 0 )  CALL  ERROR ( 99 )
  52.        CALL  CORECT
  53. C------ CK IF MORE *ID
  54. 500   WRITE(OUTPUT,1013)
  55. 1013  FORMAT( /,1X,90(1H-),// )
  56. 520   IF( ERRFLG .NE. 0 )  CALL  ERROR ( 99 )
  57.           PLIN  = PLTMP
  58.           PLTMP = PL1TMP
  59.           IF( PLIN .EQ. PL1TMP )  PLTMP = PL2TMP
  60.           ENDFILE  PLIN
  61.           REWIND  PLTMP
  62.           ENDFILE PLTMP
  63.           REWIND  PLIN
  64.           REWIND  PLTMP
  65.           IF( RESEQF .EQ. 0 )  GOTO  570
  66.                CALL  RESEQ
  67.               RESEQF = 0
  68.               GOTO  520
  69. 570       IF( BKSPFL .NE. 0 )  GOTO  400
  70.        CALL  WNEWPL
  71.       IF( ERRFLG .NE. 0 )  CALL  ERROR ( 99 )
  72.       END
  73.       SUBROUTINE  A1A4 ( I1, I4, N )
  74. C---
  75. C--- PACK 4*N WORDS OF A1 FORMAT IN I1 INTO N WORDS OF A4 FORMAT IN I4
  76. C---
  77.       DIMENSION  I1(80), I4(20)
  78.       LOGICAL*1  L1(4), L4(4)
  79.       EQUIVALENCE  ( ITEMP, L1(1) ),  ( JTEMP, L4(1) )
  80.       J = 0
  81.       DO  200  I = 1 , N
  82.           DO  100  K = 1 , 4
  83.           J = J + 1
  84.           ITEMP = I1(J)
  85.           L4(K) = L1(1)
  86.  100      CONTINUE
  87.       I4(I) = JTEMP
  88.  200  CONTINUE
  89.       RETURN
  90.       END
  91.       SUBROUTINE  A4A1 ( I4, I1, N )
  92.       DIMENSION  I4(20), I1(80)
  93.       LOGICAL*1  L4(4), L1(4)
  94.       EQUIVALENCE ( IT, L4(1) ),  ( J1, L1(1) )
  95.       DATA ISPACE/4H    /
  96.       J = 0
  97.       DO  2  I = 1 , N
  98.       IT = I4(I)
  99.           DO  1  K = 1 , 4
  100.           J1 = ISPACE    
  101.           L1(1) = L4(K)
  102.           J = J + 1
  103.           I1(J) = J1
  104. 1         CONTINUE
  105. 2     CONTINUE
  106.       RETURN
  107.       END
  108.       BLOCK DATA
  109. C---
  110. C---
  111. C---
  112.       IMPLICIT INTEGER (A-Z)
  113. C---
  114.       COMMON /CARD/   CARD(80), JCARD, LINCNT, PRTFLG, ICH
  115.      1               ,IFL(8)  , BKSPFL
  116.       COMMON /CHARS/  STAR, BLNK, COMA, PERD, SLAS
  117.       COMMON /DIR/    MSYMTB, NSYMTB, KSYMTB, ISYMTB
  118.      1              , MDIRLS, NDIRLS, KDIRLS, IDIRLS
  119.      2              , NCOMDK, NDECK , NIDENT
  120.      3              , MMEM  , NMSTOR, NMFETC
  121.      4              , MCORTB, NCORTB, MMODLS, NMODLS
  122.      5              , LASTDK
  123.       COMMON          SYMTB(7,400)  , DIRLST(5,2000)
  124.      1              , CORTBL(5,1000), MODLST(2,1000)
  125.      2              , MEM(20000)
  126.       COMMON /FILES/  INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
  127.      1              , EDTT  , PL1TMP, PL2TMP, PLTMP , PLIN
  128.       COMMON /FLAGS/  FULFLG, RESEQF, PRECOF, NPLFLG, ERRFLG
  129.      9              , WARNFL, SHOWFL
  130.       COMMON /OPTBL/  OPTBL(5,11), NOPTBL, JOP, OPARG
  131. C---
  132.       DATA  MSYMTB /400/
  133.       DATA  MDIRLS/2000/
  134.      1    , MCORTB/1000/
  135.      2    , MMODLS/1000/
  136.      3    , MMEM  /20000/
  137. C-
  138.       DATA  LINCNT /0/, BKSPFL /0/
  139. C-
  140.       DATA  STAR, BLNK, COMA, PERD, SLAS
  141.      1     /1H* , 1H  , 1H, , 1H. , 1H/ /
  142. C-
  143.       DATA  NCOMDK, NDECK, NIDENT, NDIRLS, NSYMTB /5*0/
  144. C-
  145.       DATA            INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
  146.      1              , EDTT  , PL1TMP, PL2TMP
  147.      2              / 1     , 6     , 2     , 3     , 4
  148.      3              , 10    , 11    , 12    /
  149. C-
  150.       DATA  FULFLG/1/,RESEQF/0/,PRECOF/0/,NPLFLG/1/,ERRFLG/0/
  151.      1    , WARNFL/0/
  152.       DATA  SHOWFL/1/
  153. C-
  154.       DATA  NOPTBL/11/
  155.       DATA  OPTBL /4HD   ,4HDELE,4HTE  , 9,-2,
  156.      1             4HI   ,4HINSE,4HRT  ,10,-1,
  157.      2             4HCA  ,4HCALL,4H    , 2, 1,
  158.      3             4HCD  ,4HCOMD,4HECK , 4, 1,
  159.      4             4HDK  ,4HDECK,4H    , 3, 1,
  160.      5             4HID  ,4HIDEN,4HT   , 1, 1,
  161.      6             4HAF  ,4HADDF,4HILE ,11, 2,
  162.      7             4HPC  ,4HPREC,4HOMP , 7, 0,
  163.      8             4HW   ,4HWEOF,4H    , 5, 0,
  164.      9             4HPA  ,4HPART,4HIAL , 8, 0,
  165.      1             4HS   ,4HSEQU,4HENCE, 6, 0/
  166. C---
  167.       END
  168.       SUBROUTINE  CALINP ( DKFL, ISYM, ERR )
  169. C---
  170. C--- PROCESS *CA INPUT
  171. C---
  172.       IMPLICIT INTEGER (A-Z)
  173. C---
  174.       COMMON /CHARS/  STAR, BLNK, COMA, PERD, SLAS
  175.       COMMON /DIR/    MSYMTB, NSYMTB, KSYMTB, ISYMTB
  176.      1              , MDIRLS, NDIRLS, KDIRLS, IDIRLS
  177.      2              , NCOMDK, NDECK , NIDENT
  178.      3              , MMEM  , NMSTOR, NMFETC
  179.      4              , MCORTB, NCORTB, MMODLS, NMODLS
  180.      5              , LASTDK
  181.       COMMON          SYMTB(7,400)  , DIRLST(5,2000)
  182.      1              , CORTBL(5,1000), MODLST(2,1000)
  183.      2              , MEM(20000)
  184.       COMMON /OP/     IOP(2), ID1(2), ND1, ID2(2), ND2, NOP, OP
  185. C---
  186.       ERR = 0
  187.       IF( DKFL .EQ. -1 )  GOTO  8009
  188.       IF( ID1(2) .EQ. -1 )  GOTO  8800
  189.       IF( ID1(1) .EQ. BLNK )  GOTO  8007
  190.        CALL  SYMSRC ( ID1, ISYM )
  191.       IF( ISYM .EQ. 0 )  GOTO  8010
  192.       IF( SYMTB(3,ISYM) .NE. -1 )  GOTO  8011
  193. 9000      RETURN
  194. C------ NAME MISSING
  195. 8007   CALL  ERROR ( 7 )
  196.       GOTO  8800
  197. C------ CAN*T CALL FROM A COMDECK
  198. 8009   CALL  ERROR ( 9 )
  199.       GOTO  8800
  200. C------ COMDECK NOT FOUND
  201. 8010   CALL  ERROR ( 10 )
  202.       GOTO  8800
  203. C------ CAN*T CALL A DECK
  204. 8011   CALL  ERROR ( 11 )
  205. 8800  ERR = 1
  206.       ISYM = 0
  207.       GOTO  9000
  208.       END
  209.       SUBROUTINE  CARDRD ( CREAT )
  210. C
  211. C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>  COMPILER DEPENDENT
  212. C-
  213. C--- READ ONE LINE OF CORRECTION INPUT
  214. C-
  215.       IMPLICIT INTEGER (A-Z)
  216. C---
  217.       COMMON /CARD/   CARD(80), JCARD, LINCNT, PRTFLG, ICH
  218.      1               ,IFL(8)  , BKSPFL
  219.       COMMON /CHARS/  STAR, BLNK, COMA, PERD, SLAS
  220.       COMMON /CURRID/ IDFL
  221.       COMMON /FLAGS/  FULFLG, RESEQF, PRECOF, NPLFLG, ERRFLG
  222.      9              , WARNFL, SHOWFL
  223.       COMMON /FILES/  INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
  224.      1              , EDTT  , PL1TMP, PL2TMP, PLTMP , PLIN
  225.       COMMON /OP/     IOP(2), ID1(2), ND1, ID2(2), ND2, NOP, OP
  226.       COMMON /REC/    CALFLG, TYP, DIRNUM, SEQ, CARD4(20)
  227.      1              , CARD4S(20)
  228.           DIMENSION  REC(22)
  229.               EQUIVALENCE  (DIRNUM, REC(1))
  230. C---
  231.       DATA  SHOW1/4H*/ */,  SHOW2/4HSHOW/,  SHOW3/4HNOSH/
  232. C---
  233. 1001  FORMAT( 20A4 )
  234. 1002  FORMAT( 1X,I7,1H.,20A4 )
  235. 1015  FORMAT( 1X,2H//,I5,1H.,20A4 )
  236. 1016  FORMAT( 1X,2H..,I5,1H.,20A4 )
  237. C---
  238.       CALFLG = 0
  239.       IF( BKSPFL .EQ. 0 )  GOTO  300
  240.               DO  240  I = 1 , 20
  241. 240           CARD4(I) = CARD4S(I)
  242.               GOTO  340
  243. C>>>>>>>>> *EOF* <<<<<<<<<
  244. 300   READ( INPUT, 1001, END=700 ) CARD4
  245.       LINCNT = LINCNT + 1
  246. 340    CALL  A4A1 ( CARD4(1), CARD(1), 1 )
  247.           DO  302  I = 1 , 20
  248.           I2 = 21 - I
  249.           IF( CARD4(I2) .NE. BLNK )  GOTO  304
  250. 302       CONTINUE
  251. 304   CONTINUE
  252.       OP = 0
  253.       IF( CARD(1) .NE. STAR )  GOTO  600
  254.           IF( CARD(2) .NE. SLAS )  GOTO  400
  255.       IF( (CARD4(1).EQ.SHOW1) .AND. (CARD4(2).EQ.SHOW2) )
  256.      9     SHOWFL = 1
  257.       IF( (CARD4(1).EQ.SHOW1) .AND. (CARD4(2).EQ.SHOW3) )
  258.      9     SHOWFL = 0
  259.               WRITE( OUTPUT, 1016 )  LINCNT, (CARD4(I), I=1,I2)
  260.               GOTO  300
  261. 400        CALL  A4A1 ( CARD4(2), CARD(5), 19 )
  262.            CALL  OPGET
  263.           IF( OP .EQ. 0 )  GOTO  600
  264.           TYP = OP
  265.           IF( (BKSPFL .NE. 0) .OR. (OP .EQ. 1) )  GOTO  900
  266.               WRITE( OUTPUT, 1015 )  LINCNT, (CARD4(I), I=1,I2)
  267.               GOTO  900
  268. 600   TYP = 1
  269.       IF( CREAT .NE. 0 )  GOTO  900
  270.           WRITE( OUTPUT, 1002 )  LINCNT, (CARD4(I), I=1,I2)
  271. 900   BKSPFL = 0
  272.       RETURN
  273. 700   OP = 99
  274.       GOTO  900
  275.       END
  276.       SUBROUTINE  COMPWT ( REC )
  277. C---
  278. C--- WRITE ONE LINE OF COMPILE FILE
  279. C---
  280.       IMPLICIT INTEGER (A-Z)
  281. C---
  282.       COMMON /DIR/    MSYMTB, NSYMTB, KSYMTB, ISYMTB
  283.      1              , MDIRLS, NDIRLS, KDIRLS, IDIRLS
  284.      2              , NCOMDK, NDECK , NIDENT
  285.      3              , MMEM  , NMSTOR, NMFETC
  286.      4              , MCORTB, NCORTB, MMODLS, NMODLS
  287.      5              , LASTDK
  288.       COMMON          SYMTB(7,400)  , DIRLST(5,2000)
  289.      1              , CORTBL(5,1000), MODLST(2,1000)
  290.      2              , MEM(20000)
  291.       COMMON /FILES/  INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
  292.      1              , EDTT  , PL1TMP, PL2TMP, PLTMP , PLIN
  293.       COMMON /FLAGS/  FULFLG, RESEQF, PRECOF, NPLFLG, ERRFLG
  294.      9              , WARNFL, SHOWFL
  295. C---
  296.       DIMENSION  REC(22), NM(2), LINE1(20), LINE2(20)
  297. C---
  298.       J = REC(1)
  299.       NM(1) = SYMTB(1,J)
  300.       NM(2) = SYMTB(2,J)
  301.       IF(PRECOF .EQ. 0)  GOTO 10
  302.       CALL PRECMP(REC(3),LINE1,LINE2,NL)
  303.       IF( PRECOF .EQ. 0 )  GOTO  10
  304.       IF( REC(2) .LT. 100 )  GOTO  20
  305.       IF( REC(2) .LT.1000 )  GOTO  30
  306.         WRITE(COMPIL,44) LINE1, NM, REC(2)
  307.         IF(NL .EQ. 2)
  308.      1  WRITE(COMPIL,44) LINE2, NM, REC(2)
  309.       GOTO  900
  310. 30      WRITE(COMPIL,33) LINE1, NM, REC(2)
  311.         IF(NL .EQ. 2)
  312.      1  WRITE(COMPIL,33) LINE2, NM, REC(2)
  313.       GOTO  900
  314. 20      WRITE(COMPIL,22) LINE1, NM, REC(2)
  315.         IF(NL .EQ. 2)
  316.      1  WRITE(COMPIL,22) LINE2, NM, REC(2)
  317.       GOTO 900
  318.    10 IF( REC(2) .LT. 100 )  GOTO  2
  319.       IF( REC(2) .LT.1000 )  GOTO  3
  320.         WRITE(COMPIL,44) (REC(I), I=3,22), NM, REC(2)
  321.       GOTO  900
  322. 3       WRITE(COMPIL,33) (REC(I), I=3,22), NM, REC(2)
  323.       GOTO  900
  324. 2       WRITE(COMPIL,22) (REC(I), I=3,22), NM, REC(2)
  325. 900   RETURN
  326. 22    FORMAT( 22A4,I2 )
  327. 33    FORMAT( 21A4,A3,I3 )
  328. 44    FORMAT( 21A4,A2,I4 )
  329.       END
  330.       SUBROUTINE  CORECT
  331. C---
  332. C--- CORRECT (PLIN) WITH (MEM) CREATING (PLTMP)
  333. C---
  334.       IMPLICIT INTEGER (A-Z)
  335. C---
  336.       COMMON /CURRID/ IDFL
  337.       COMMON /DIR/    MSYMTB, NSYMTB, KSYMTB, ISYMTB
  338.      1              , MDIRLS, NDIRLS, KDIRLS, IDIRLS
  339.      2              , NCOMDK, NDECK , NIDENT
  340.      3              , MMEM  , NMSTOR, NMFETC
  341.      4              , MCORTB, NCORTB, MMODLS, NMODLS
  342.      5              , LASTDK
  343.       COMMON          SYMTB(7,400)  , DIRLST(5,2000)
  344.      1              , CORTBL(5,1000), MODLST(2,1000)
  345.      2              , MEM(20000)
  346.       COMMON /FILES/  INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
  347.      1              , EDTT  , PL1TMP, PL2TMP, PLTMP , PLIN
  348.       COMMON /FLAGS/  FULFLG, RESEQF, PRECOF, NPLFLG, ERRFLG
  349.      9              , WARNFL, SHOWFL
  350.       COMMON /REC/    CALFLG, TYP, DIRNUM, SEQ, CARD4(20)
  351.      1              , CARD4S(20)
  352.           DIMENSION  REC(22)
  353.               EQUIVALENCE  (DIRNUM, REC(1))
  354. C---
  355.       DIMENSION  SYMTB2(7,300), DIRLS2(5,500)
  356.             EQUIVALENCE ( MEM(1), SYMTB2(1,1), DIRLS2(1,1) )
  357.       DIMENSION  SEQ0(2)
  358.             DATA SEQ0 / 0, 0 /
  359. C---
  360.       IF( SHOWFL .NE. 0 )  CALL  DIPRNT( -1 )
  361.       KDIRLS = NDIRLS
  362.       IDSEQ  = 0
  363.        CALL  RDPLIN
  364.       DO  10000  IDIRLS = 1 , NDIRLS
  365.       IF( DIRLST(5,IDIRLS) .EQ. 0 )  GOTO  10000
  366.         JDIRLS = IDIRLS
  367.         IM = DIRLST(5,JDIRLS)
  368. 1200    IC = MODLST(1,IM)
  369.         OP = CORTBL(1,IC)
  370.         IF( SHOWFL .NE. 0 )  CALL  DIPRNT( 0 )
  371.             IDF   = IDFL
  372.             IF( OP .NE. 11 )  GOTO  1800
  373. C...............*AF
  374.                 ISY = CORTBL(2,IC)
  375. C....................LOOK THRU DIRLST TO FIND LAST LINE
  376. 1300             IF( SYMTB(6,ISY) .EQ. 0 )  GOTO  1310
  377.                      ISY = SYMTB(6,ISY)
  378.                      GOTO  1300
  379. 1310            I = SYMTB(5,ISY)
  380. 1320            IF( DIRLST(4,I) .LT. 0 )  GOTO  1330
  381.                     I = DIRLST(4,I)
  382.                     GOTO  1320
  383. 1330            CORTBL(2,IC) = DIRLST(1,I)
  384.                 CORTBL(3,IC) = DIRLST(3,I)
  385. 1800    CORFRM = IDSEQ + 1
  386.          CALL  FIND ( CORTBL(2,IC) )
  387.         IF( OP .EQ. 9 )  CALL  DELET ( CORTBL(2,IC+1) )
  388.           IF( CORTBL(5,IC) .EQ. 0 )  GOTO  9000
  389.             CORSEQ = SEQ
  390.             N      = CORTBL(5,IC)
  391.             NMFETC = CORTBL(4,IC)
  392.               DO  2100  I = 1 , N
  393.                CALL  WTPL ( PLTMP )
  394.                CALL  MEMFET
  395.               IF( TYP .LT. 3 )  GOTO  1900
  396.                   AFSEQ = 0
  397.                   IDF    = DIRNUM
  398.                   SYMTB(6,ISY) = DIRNUM
  399.                   ISY = DIRNUM
  400. 1900          DIRNUM = IDF
  401.               TYP    = IABS ( TYP )
  402.               IF( OP .EQ. 11 )  GOTO  1950
  403.                   IDSEQ = IDSEQ + 1
  404.                   SEQ   = IDSEQ
  405.                 GOTO  2000
  406. 1950              AFSEQ = AFSEQ + 1
  407.                   SEQ   = AFSEQ
  408. 2000          IF( SHOWFL .NE. 0 )  CALL  DIPRNT( 2 )
  409. 2100          CONTINUE
  410.             IF( OP .EQ. 11 )  GOTO  9000
  411. C------ MODIFY DIRLST
  412.             NEXT = DIRLST(4,JDIRLS)
  413.             KDIRLS = KDIRLS + 1
  414.             IF( KDIRLS + 1 .GT. MDIRLS )  CALL  ERROR ( 20 )
  415.             DIRLST(1,KDIRLS) = IDF
  416.             DIRLST(2,KDIRLS) = CORFRM
  417.             DIRLST(3,KDIRLS) = IDSEQ
  418.             DIRLST(4,KDIRLS) = NEXT
  419.             DIRLST(5,KDIRLS) = 0
  420.             OLDTO = DIRLST(3,JDIRLS)
  421.             DIRLST(3,JDIRLS) = CORSEQ
  422.             DIRLST(4,JDIRLS) = KDIRLS
  423.             IF( OLDTO .EQ. CORSEQ )  GOTO  4000
  424.               DIRLST(4,KDIRLS) = KDIRLS + 1
  425.               KDIRLS = KDIRLS + 1
  426.               DIRLST(1,KDIRLS) = DIRLST(1,JDIRLS)
  427.               DIRLST(2,KDIRLS) = CORSEQ + 1
  428.               DIRLST(3,KDIRLS) = OLDTO
  429.               DIRLST(4,KDIRLS) = NEXT
  430.               DIRLST(5,KDIRLS) = 0
  431. 4000        CONTINUE
  432. C......... CHANGE JDIRLS
  433.             JDIRLS = KDIRLS
  434. 9000    IM = MODLST(2,IM)
  435.         IF( IM .NE. 0 )  GOTO  1200
  436. 10000 CONTINUE
  437. C------ COPY REST OF PLIN TO PLTMP
  438.        CALL  FIND ( SEQ0 )
  439. C------ CORRECT SYMTB
  440.       J = 0
  441.       DO  30150  I = 1 , KSYMTB
  442.       K = I
  443. 30110   J = J + 1
  444.           DO  30120  JJ = 1 , 6
  445. 30120     SYMTB2(JJ,J) = SYMTB(JJ,K)
  446.         SYMTB(7,K) = J
  447.         IF( SYMTB2(6,J) .EQ. 0 )  GOTO  30150
  448.           K = SYMTB2(6,J)
  449.           SYMTB2(6,J) = 0
  450.           GOTO  30110
  451. 30150 CONTINUE
  452.         DO  30180  I = 1 , NSYMTB
  453.           DO  30170  II = 1 , 6
  454. 30170     SYMTB(II,I) = SYMTB2(II,I)
  455. 30180   CONTINUE
  456.       NCORTB = 0
  457.       NMODLS = 0
  458. C------ CORRECT DIRLST
  459.       J = 0
  460.       DO  30270  I = 1 , NSYMTB
  461.       IF( (SYMTB(3,I) .EQ. 0) .OR. (SYMTB(4,I) .EQ. 0) ) GOTO 30270
  462.       K = SYMTB(5,I)
  463.       SYMTB(5,I) = J + 1
  464. 30220 J = J + 1
  465.           DO  30230  JJ = 2 , 4
  466. 30230     DIRLS2(JJ,J) = DIRLST(JJ,K)
  467.           DIRLS2(5,J)  = 0
  468.       II = DIRLST(1,K)
  469.       DIRLS2(1,J) = SYMTB(7,II)
  470.       IF( DIRLS2(4,J) .LT. 0 )  GOTO  30260
  471.           K = DIRLS2(4,J)
  472.           DIRLS2(4,J) = J + 1
  473.           GOTO  30220
  474. 30260 II = IABS( DIRLS2(4,J) )
  475.       DIRLS2(4,J) = -SYMTB(7,II)
  476. 30270 CONTINUE
  477.           DO  30290  I = 1 , KDIRLS
  478.               DO 30280  II = 1 , 5
  479. 30280         DIRLST(II,I) = DIRLS2(II,I)
  480. 30290     CONTINUE
  481.       NDIRLS = KDIRLS
  482.       RETURN
  483.       END
  484.       SUBROUTINE  CORRD
  485. C---
  486. C------ READ AND PREPROCESS CORRECTION INPUT
  487. C---
  488.       IMPLICIT INTEGER (A-Z)
  489. C---
  490.       COMMON /CARD/   CARD(80), JCARD, LINCNT, PRTFLG, ICH
  491.      1               ,IFL(8)  , BKSPFL
  492.       COMMON /CHARS/  STAR, BLNK, COMA, PERD, SLAS
  493.       COMMON /COUNT/  COUNT
  494.       COMMON /CURRDK/ IXSYM , IXDIR , NCDS
  495.       COMMON /CURRID/ IDFL
  496.       COMMON /DIR/    MSYMTB, NSYMTB, KSYMTB, ISYMTB
  497.      1              , MDIRLS, NDIRLS, KDIRLS, IDIRLS
  498.      2              , NCOMDK, NDECK , NIDENT
  499.      3              , MMEM  , NMSTOR, NMFETC
  500.      4              , MCORTB, NCORTB, MMODLS, NMODLS
  501.      5              , LASTDK
  502.       COMMON          SYMTB(7,400)  , DIRLST(5,2000)
  503.      1              , CORTBL(5,1000), MODLST(2,1000)
  504.      2              , MEM(20000)
  505.       COMMON /FILES/  INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
  506.      1              , EDTT  , PL1TMP, PL2TMP, PLTMP , PLIN
  507.       COMMON /FLAGS/  FULFLG, RESEQF, PRECOF, NPLFLG, ERRFLG
  508.      9              , WARNFL, SHOWFL
  509.       COMMON /OPTBL/  OPTBL(5,11), NOPTBL, JOP, OPARG
  510.       COMMON /OP/     IOP(2), ID1(2), ND1, ID2(2), ND2, NOP, OP
  511.       COMMON /REC/    CALFLG, TYP, DIRNUM, SEQ, CARD4(20)
  512.      1              , CARD4S(20)
  513.           DIMENSION  REC(22)
  514.               EQUIVALENCE  (DIRNUM, REC(1))
  515. C---
  516.       DIMENSION   NOID(2)
  517.             DATA  NOID/ 4H.NO., 4HID.  /
  518. C---
  519.       KSYMTB = NSYMTB
  520.       NMSTOR = 0
  521.       NCORTB = 0
  522.       NMODLS = 0
  523.       CORDK  = 0
  524.       ICORTB = 0
  525.       DIFL = 0
  526.       IDFL = 0
  527.       NCDS = 0
  528. 100    CALL  CARDRD ( 0 )
  529.       IF( OP .NE. 0 )  GOTO  500
  530. 200       IF( DIFL .EQ. 0 )  CALL  ERROR ( 22 )
  531. 220       NCDS = NCDS + 1
  532. C......... PUT IN MEM
  533.            CALL  MEMSTO
  534.           IF( IDFL .NE. 0 )  SYMTB(4,IDFL) = SYMTB(4,IDFL) + 1
  535.           IF( ICORTB .NE. 0 )  CORTBL(5,ICORTB) = CORTBL(5,ICORTB)+1
  536.           GOTO  100
  537. 500   IF( OP .EQ. 99 )  GOTO  90000
  538.       IF( (OP.EQ.1) .OR. ((OP.GE.6).AND.(OP.LE.8)) )  GOTO  520
  539.           IF( IDFL .NE. 0 )  GOTO  520
  540.                CALL  ERROR ( 13 )
  541.               BKSPFL = 1
  542.                   DO  510  I = 1 , 20
  543. 510               CARD4S(I) = CARD4(I)
  544.               NPLFLG = 0
  545.               ID1(1) = NOID(1)
  546.               ID1(2) = NOID(2)
  547.               GOTO  1200
  548. 520   IF( (OP.NE.9) .AND. (OP.NE.10) .AND.
  549.      1    (OP.NE.2) .AND. (OP.NE.5)  )  DIFL = 0
  550.       CALL  OPGET2
  551.       GOTO  ( 1000, 2000, 3000, 4000, 5000, 6000, 7000, 8000
  552.      1       ,9000,10000,11000 ) , OP
  553. C------ *ID
  554. 1000  IF( IDFL .EQ. 0 )  GOTO  1100
  555.           BKSPFL = 1
  556.           DO  1010  I = 1 , 20
  557. 1010      CARD4S(I) = CARD4(I)
  558.           GOTO  90000
  559. 1100  WRITE( OUTPUT, 1015 ) LINCNT, CARD4
  560. 1015  FORMAT( 1X,2H//,I5,1H.,20A4 )
  561. 1200   CALL  SYMENT ( 0, SYMERR )
  562.       IF( SYMERR .NE. 0 )  CALL  ERROR ( 99 )
  563.       NIDENT = NIDENT + 1
  564.       IDFL = ISYMTB
  565.       KSYMTB = ISYMTB
  566. C........... TEMPORARILY DELETE ID NAME FROM SYMBOL TABLE
  567.       IDNAM1 = SYMTB(1,IDFL)
  568.       SYMTB(1,IDFL) = 0
  569.       GOTO  100
  570. C------ *CA
  571. 2000   CALL  CALINP ( CORDK, ISYM, ERR )
  572.       IF( ERR .NE. 0 )  GOTO  100
  573.       CALFLG = ISYM
  574.       GOTO  220
  575. C------ *DK
  576. 3000  CONTINUE
  577. C------ *CD
  578. 4000   CALL  ERROR ( 14 )
  579. C------ *WEOF, *RESEQUENCE, *PRECOMPILE, *PARTIAL
  580. 5000  GOTO  200
  581. 6000  RESEQF = 1
  582.           GOTO  100
  583. 7000  PRECOF = 1
  584.           GOTO  100
  585. 8000  FULFLG = 0
  586.       GOTO  100
  587. C------ *D
  588. 9000  CONTINUE
  589. C------ *I
  590. 10000 DIFL = 1
  591.        CALL  SYMSRC ( ID1, ISY1 )
  592.       IF( ISY1 .EQ. 0 )  GOTO  10818
  593.       IF( ND1 .GT. IABS( SYMTB(4,ISY1) ) )  GOTO  10815
  594.       IF( OP .NE. 9 )  GOTO  10200
  595.         IF( ID2(1) .NE. BLNK )  GOTO  10100
  596.           ISY2 = ISY1
  597.           ND2  = ND1
  598.           GOTO  10200
  599. 10100    CALL  SYMSRC ( ID2, ISY2 )
  600.         IF( ISY2 .EQ. 0 )  GOTO  10818
  601.         IF( ND2  .GT. IABS( SYMTB(4,ISY2) ) )  GOTO  10815
  602. 10200   NCORTB = NCORTB + 1
  603.         IF( NCORTB .GT. MCORTB )  CALL  ERROR ( 16 )
  604.         ICORTB = NCORTB
  605.           CORTBL(1,NCORTB) = OP
  606.           CORTBL(2,NCORTB) = ISY1
  607.           CORTBL(3,NCORTB) = ND1
  608.           CORTBL(4,NCORTB) = NMSTOR + 1
  609.           CORTBL(5,NCORTB) = 0
  610.         IF( OP .NE. 9 )  GOTO  10300
  611.           NCORTB = NCORTB + 1
  612.           IF( NCORTB .GT. MCORTB )  CALL  ERROR ( 16 )
  613.             CORTBL(1,NCORTB) = 0
  614.             CORTBL(2,NCORTB) = ISY2
  615.             CORTBL(3,NCORTB) = ND2
  616.             CORTBL(4,NCORTB) = 0
  617.             CORTBL(5,NCORTB) = 0
  618. 10300 CONTINUE
  619.         DO  10310  I = 1 , NDIRLS
  620.         IF( ISY1 .NE. DIRLST(1,I) )  GOTO  10310
  621.         IF( ND1  .LT. DIRLST(2,I) )  GOTO  10310
  622.         IF( OP .EQ. 11 )  GOTO  10320
  623.         IF( ND1  .LE. DIRLST(3,I) )  GOTO  10320
  624. 10310   CONTINUE
  625.         GOTO  10815
  626. 10320 CONTINUE
  627. C........... SET CORDK = DK TYPE WHERE CORR IS MADE
  628.         DO  10330  II = I , NDIRLS
  629.         IF( DIRLST(4,II) .LT. 0 )  GOTO  10340
  630. 10330   CONTINUE
  631.         STOP
  632. 10340 IF( OP .NE. 11 )  GOTO  10350
  633.           ISY1 = DIRLST(1,II)
  634.           I    = II
  635.           GOTO  10360
  636. C------- PUT COMPILE FLAG IN SYMTB(4,II)
  637. 10350   II = IABS( DIRLST(4,II) )
  638.         SYMTB(4,II) = - IABS( SYMTB(4,II) )
  639. 10360   CORDK = SYMTB(3,II)
  640.       NMODLS = NMODLS + 1
  641.       IF( NMODLS .GT. MMODLS )  CALL  ERROR ( 17 )
  642.       MODLST(1,NMODLS) = ICORTB
  643.       MODLST(2,NMODLS) = 0
  644.       IF( DIRLST(5,I) .GT. 0 )  GOTO  10400
  645.           DIRLST(5,I) = NMODLS
  646.           GOTO  10700
  647. C.......... PUT THIS CORRECTION IN SORTED ORDER IN MODLST( , )
  648. 10400 MSTART = DIRLST(5,I)
  649.       M      = MSTART
  650.       MOLD   = 0
  651. 10440 C = MODLST(1,M)
  652.       IF( ND1 .LT. CORTBL(3,C) )  GOTO  10460
  653.           IF( MODLST(2,M) .EQ. 0 )  GOTO  10450
  654.               MOLD = M
  655.               M    = MODLST(2,M)
  656.               GOTO  10440
  657. 10450     MODLST(2,M) = NMODLS
  658.           GOTO  10700
  659. 10460 IF( MOLD .NE. 0 )  GOTO  10470
  660.           DIRLST(5,I) = NMODLS
  661.           MODLST(2,NMODLS) = MSTART
  662.           GOTO  10700
  663. 10470 MODLST(2,NMODLS) = M
  664.       MODLST(2,MOLD)   = NMODLS
  665. 10700 CONTINUE
  666.       GOTO  10900
  667. 10818  CALL  ERROR ( 18 )
  668.       GOTO  10900
  669. 10815  CALL  ERROR ( 15 )
  670. 10900 IF( OP .EQ. 11 )  GOTO  11500
  671.           GOTO  100
  672. C------ *AF
  673. 11000 ND1 =999999
  674.       IF( ID2(1) .EQ. BLNK )  GOTO  11300
  675.            CALL  SYMSRC ( ID2, ISY1 )
  676.           IF( ISY1 .EQ. 0 )  GOTO  11818
  677.           GOTO  11400
  678. 11300 ISY1 = LASTDK
  679. 11400 GOTO  10200
  680. 11500  CALL  CREATE ( 0, ERRCRT )
  681.       CORTBL(5,ICORTB) = COUNT
  682.       IF( BKSPFL .NE. 0 )  GOTO  100
  683.       GOTO  90000
  684. 11818  CALL  ERROR ( 18 )
  685.       GOTO  11300
  686. C........... RESTORE ID NAME IN SYMBOL TABLE
  687. 90000 IF( IDFL .NE. 0 )  SYMTB(1,IDFL) = IDNAM1
  688.       RETURN
  689.       END
  690.       SUBROUTINE  CRAK2 ( IFLD, ER1FLG )
  691. C---
  692. C--- COLLECT A FIELD TERMINATED BY <.>,< >,<,> IGNORING LEADING BLANKS
  693. C---
  694.       IMPLICIT INTEGER (A-Z)
  695. C---
  696.       COMMON /CARD/   CARD(80), JCARD, LINCNT, PRTFLG, ICH
  697.      1               ,IFL(8)  , BKSPFL
  698.       COMMON /CHARS/  STAR, BLNK, COMA, PERD, SLAS
  699. C---
  700.       DIMENSION  IFLD(2)
  701. C---
  702.       IFLD(1) = BLNK
  703.       IFLD(2) = BLNK
  704.       LEADFL = 1
  705.       J      = 0
  706. 100   JCARD    = JCARD + 1
  707.       IF( JCARD .GT. 80 )  GOTO 250
  708.         ICH = CARD(JCARD)
  709.         IF( ICH .NE. BLNK )  GOTO 200
  710.           IF( LEADFL .EQ. 0 )  GOTO 300
  711.             GOTO 100
  712. 200     LEADFL = 0
  713.         IF((ICH.EQ.COMA).OR.(ICH.EQ.PERD)) GOTO 300
  714.           J = J+1
  715.           IF( J .LT. 9 )  IFL(J) = ICH
  716.           GOTO  100
  717. 250   ICH = BLNK
  718. 300   IF( J .EQ. 0 )  GOTO  900
  719.       IF( (J .GT. 8) .AND. (ER1FLG .NE. 0) )  GOTO  801
  720.       IF( J .GE. 8 )  GOTO  700
  721.         J1 = J+1
  722.         DO 400  JJ = J1 , 8
  723. 400     IFL(JJ) = BLNK
  724. 700   CALL  A1A4 ( IFL, IFLD, 2 )
  725. 900   RETURN
  726. C------ ERR. FIELD GT 8 CHARS
  727. 801       CALL  ERROR ( 1 )
  728.          IFLD(2) = -1
  729.           GOTO  900
  730.       END
  731.       SUBROUTINE  CREATE ( OUTFIL, ERRCRT )
  732. C---
  733. C--- CREATE TEMPORARY NEWPL FROM SOURCE INPUT
  734. C---
  735.       IMPLICIT INTEGER (A-Z)
  736. C---
  737.       COMMON /CARD/   CARD(80), JCARD, LINCNT, PRTFLG, ICH
  738.      1               ,IFL(8)  , BKSPFL
  739.       COMMON /CHARS/  STAR, BLNK, COMA, PERD, SLAS
  740.       COMMON /COUNT/  COUNT
  741.       COMMON /CURRDK/ IXSYM , IXDIR , NCDS
  742.       COMMON /DIR/    MSYMTB, NSYMTB, KSYMTB, ISYMTB
  743.      1              , MDIRLS, NDIRLS, KDIRLS, IDIRLS
  744.      2              , NCOMDK, NDECK , NIDENT
  745.      3              , MMEM  , NMSTOR, NMFETC
  746.      4              , MCORTB, NCORTB, MMODLS, NMODLS
  747.      5              , LASTDK
  748.       COMMON          SYMTB(7,400)  , DIRLST(5,2000)
  749.      1              , CORTBL(5,1000), MODLST(2,1000)
  750.      2              , MEM(20000)
  751.       COMMON /FILES/  INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
  752.      1              , EDTT  , PL1TMP, PL2TMP, PLTMP , PLIN
  753.       COMMON /FLAGS/  FULFLG, RESEQF, PRECOF, NPLFLG, ERRFLG
  754.      9              , WARNFL, SHOWFL
  755.       COMMON /OPTBL/  OPTBL(5,11), NOPTBL, JOP, OPARG
  756.       COMMON /OP/     IOP(2), ID1(2), ND1, ID2(2), ND2, NOP, OP
  757.       COMMON /REC/    CALFLG, TYP, DIRNUM, SEQ, CARD4(20)
  758.      1              , CARD4S(20)
  759.           DIMENSION  REC(22)
  760.               EQUIVALENCE  (DIRNUM, REC(1))
  761. C---
  762. C------   PLTMP  = TEMP. NEWPL FILE
  763. C------   LINCNT = INPUT LINE COUNT
  764. C------   NCDS   = NUMBER OF CARDS IN ONE CD OR DK BLOCK
  765. C------   DKFL   = --1 FOR CD, 1 FOR DK, 0 FOR UNDEF
  766. C---
  767.       CRTFIL = OUTFIL
  768.       ERRCRT = 0
  769.       NCDS   = 0
  770.       DKFL   = 0
  771.       IXSYM  = 0
  772.       IXDIR  = 0
  773.       COUNT  = 0
  774. C-
  775. 100    CALL  CARDRD ( 1 )
  776.       IF( OP .NE. 0 )  GOTO  500
  777.           OP = 1
  778. 200       IF( DKFL .EQ. 0 )  CALL  ERROR ( 3 )
  779.           NCDS = NCDS + 1
  780.           TYP = OP
  781.           DIRNUM = IXSYM
  782.           SEQ = NCDS
  783.            CALL  WTPL ( CRTFIL )
  784.           COUNT = COUNT + 1
  785.           IF(IXSYM .GT. 0)  SYMTB(4,IXSYM) = SYMTB(4,IXSYM)+1
  786.           IF(IXDIR .GT. 0)  DIRLST(3,IXDIR) = DIRLST(3,IXDIR)+1
  787.           GOTO  100
  788. 500   IF( OP .EQ. 99 )  GOTO  9000
  789.       IF( (OUTFIL .EQ. 0) .AND. (OP .EQ. 11) )  GOTO  1000
  790.       IF( OP .GT. 7 )  GOTO  8000
  791.       IF( OP .NE. 1 )  CALL  OPGET2
  792.       GOTO (1000, 2000, 3000, 3000, 5000, 6000, 7000) , OP
  793. C------ *ID
  794. 1000  BKSPFL = 1
  795.           DO  1010  I = 1 , 20
  796. 1010      CARD4S(I) = CARD4(I)
  797.       GOTO  9000
  798. C------ *CA
  799. 2000   CALL  CALINP ( DKFL, ISYM, ERR )
  800.       IF( ERR .NE. 0 )  GOTO  100
  801.       CALFLG = ISYM
  802.       GOTO  200
  803. C------ *DK, *CD
  804. 3000   CALL  DKCDIN ( DKFL )
  805.       GOTO  200
  806. C------ *WEOF, *RESEQUENCE, *PRECOMPILE
  807. 5000  GOTO  200
  808. 6000  RESEQF = 1
  809.       GOTO  100
  810. 7000  PRECOF = 1
  811.       GOTO  100
  812. C------ BAD UPDATE COMMAND
  813. 8000   CALL  ERROR ( 8 )
  814.       ERRCRT = 1
  815.       GOTO  100
  816. 9000  RETURN
  817.       END
  818.       SUBROUTINE  DELET ( DNSQ )
  819. C-
  820. C--- WHILE INACTIVATING COPY PLIN TO PLTMP UNTIL DNSQ FOUND
  821. C-
  822.       IMPLICIT INTEGER (A-Z)
  823. C---
  824.       COMMON /FILES/  INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
  825.      1              , EDTT  , PL1TMP, PL2TMP, PLTMP , PLIN
  826.       COMMON /FLAGS/  FULFLG, RESEQF, PRECOF, NPLFLG, ERRFLG
  827.      9              , WARNFL, SHOWFL
  828.       COMMON /REC/    CALFLG, TYP, DIRNUM, SEQ, CARD4(20)
  829.      1              , CARD4S(20)
  830.           DIMENSION  REC(22)
  831.               EQUIVALENCE  (DIRNUM, REC(1))
  832. C---
  833.       DIMENSION  DNSQ(2)
  834. C---
  835.       DN = DNSQ(1)
  836.       SQ = DNSQ(2)
  837. 100   TYP = -IABS ( TYP )
  838.       IF( SHOWFL .NE. 0 )  CALL  DIPRNT( 1 )
  839.       IF( SQ .NE. SEQ )  GOTO  200
  840.       IF( DN .EQ. DIRNUM )  GOTO  900
  841. 200    CALL  WTPL ( PLTMP )
  842.        CALL  RDPLIN
  843.       GOTO  100
  844. 900   RETURN
  845.       END
  846.       SUBROUTINE  DIPRNT ( IDI )
  847. C---
  848. C--- PRINT DELETED AND INSERTED LINES
  849. C---     IDI =-1 PRINT HEADING,  =0 PRINT SPACE
  850. C---         =1  PRINT DELETED LINE, =2 PRINT INSERTED LINE
  851. C---
  852.       IMPLICIT INTEGER (A-Z)
  853. C---
  854.       COMMON /CHARS/  STAR, BLNK, COMA, PERD, SLAS
  855.       COMMON /DIR/    MSYMTB, NSYMTB, KSYMTB, ISYMTB
  856.      1              , MDIRLS, NDIRLS, KDIRLS, IDIRLS
  857.      2              , NCOMDK, NDECK , NIDENT
  858.      3              , MMEM  , NMSTOR, NMFETC
  859.      4              , MCORTB, NCORTB, MMODLS, NMODLS
  860.      5              , LASTDK
  861.       COMMON          SYMTB(7,400)  , DIRLST(5,2000)
  862.      1              , CORTBL(5,1000), MODLST(2,1000)
  863.      2              , MEM(20000)
  864.       COMMON /FILES/  INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
  865.      1              , EDTT  , PL1TMP, PL2TMP, PLTMP , PLIN
  866.       COMMON /REC/    CALFLG, TYP, DIRNUM, SEQ, CARD4(20)
  867.      1              , CARD4S(20)
  868.           DIMENSION  REC(22)
  869.               EQUIVALENCE  (DIRNUM, REC(1))
  870. C---
  871.       DIMENSION  DI(2)
  872.           DATA  DI/2HD , 2H I/
  873. C---
  874.       IF( IDI .LE. 0 )  GOTO  500
  875.           IF( IABS( TYP ) .GT. 2 )  GOTO  450
  876.           IF( CALFLG .GT. 0 )  GOTO  400
  877.                   DO  302  I = 1 , 20
  878.                   I2 = 21 - I
  879.                   IF( CARD4(I2) .NE. BLNK )  GOTO  304
  880. 302               CONTINUE
  881. 304               CONTINUE
  882.               WRITE(OUTPUT,101)  DI(IDI), SYMTB(1,DIRNUM)
  883.      .                         , SYMTB(2,DIRNUM), SEQ
  884.      .                         , (CARD4(I), I=1,I2)
  885. C ..101           FORMAT( 1X , A2, 3H ( , 2A4, I4,3H )  20A4 )     8-11-86
  886. 101           FORMAT( 1X , A2, 3H ( , 2A4, I4,3H ) , 20A4 )
  887.               RETURN
  888. 400       WRITE(OUTPUT,102)  DI(IDI), SYMTB(1,DIRNUM), SYMTB(2,DIRNUM)
  889.      .                     , SEQ, SYMTB(1,CALFLG), SYMTB(2,CALFLG)
  890. 102       FORMAT( 1X, A2, 3H ( , 2A4, I4,7H ) *CA , 2A4 )
  891.           RETURN
  892. 450       IF( IABS( TYP ) .EQ. 3 )
  893.      .      WRITE(OUTPUT,103)  DI(IDI), SYMTB(1,DIRNUM), SYMTB(2,DIRNUM)
  894.      .                       , SEQ, SYMTB(1,DIRNUM), SYMTB(2,DIRNUM)
  895. 103         FORMAT( 1X, A2, 3H ( , 2A4, I4,9H ) *DECK , 2A4 )
  896.           IF( IABS( TYP ) .EQ. 4 )
  897.      .      WRITE(OUTPUT,104)  DI(IDI), SYMTB(1,DIRNUM), SYMTB(2,DIRNUM)
  898.      .                       , SEQ, SYMTB(1,DIRNUM), SYMTB(2,DIRNUM)
  899. 104         FORMAT( 1X, A2, 3H ( , 2A4, I4,12H ) *COMDECK , 2A4 )
  900.             RETURN
  901. 500   IF( IDI .NE. 0 )  GOTO  600
  902.           WRITE(OUTPUT,105)
  903. 105       FORMAT( 1X )
  904.           RETURN
  905. 600       WRITE(OUTPUT,106)
  906. 106       FORMAT( //, 28H U P D A T E   MODIFICATIONS  )
  907.           RETURN
  908.       END
  909.       SUBROUTINE  DKCDIN ( DKFL )
  910. C-
  911. C--- PROCESS *DK, *CD INPUT
  912. C-
  913.       IMPLICIT INTEGER (A-Z)
  914. C---
  915.       COMMON /CARD/   CARD(80), JCARD, LINCNT, PRTFLG, ICH
  916.      1               ,IFL(8)  , BKSPFL
  917.       COMMON /CURRDK/ IXSYM , IXDIR , NCDS
  918.       COMMON /DIR/    MSYMTB, NSYMTB, KSYMTB, ISYMTB
  919.      1              , MDIRLS, NDIRLS, KDIRLS, IDIRLS
  920.      2              , NCOMDK, NDECK , NIDENT
  921.      3              , MMEM  , NMSTOR, NMFETC
  922.      4              , MCORTB, NCORTB, MMODLS, NMODLS
  923.      5              , LASTDK
  924.       COMMON          SYMTB(7,400)  , DIRLST(5,2000)
  925.      1              , CORTBL(5,1000), MODLST(2,1000)
  926.      2              , MEM(20000)
  927.       COMMON /FILES/  INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
  928.      1              , EDTT  , PL1TMP, PL2TMP, PLTMP , PLIN
  929.       COMMON /OP/     IOP(2), ID1(2), ND1, ID2(2), ND2, NOP, OP
  930. C---
  931.       IF( OP .EQ. 4 )  GOTO  1000
  932. C------ *DK
  933.       DKFL = 1
  934.       NDECK = NDECK + 1
  935.       GOTO  1200
  936. C------ *CD
  937. 1000  DKFL = -1
  938.       NCOMDK = NCOMDK + 1
  939. C------ *DK, *CD
  940. 1200  NCDS = 0
  941.        CALL  SYMENT ( DKFL, SYMERR )
  942.       IXSYM = ISYMTB
  943.       NDIRLS = NDIRLS + 1
  944.       IF( NDIRLS .GT. MDIRLS )  CALL  ERROR ( 20 )
  945.       IXDIR  = NDIRLS
  946.       SYMTB(4,IXSYM) = 0
  947.       SYMTB(5,IXSYM) = NDIRLS
  948.       DIRLST(1,IXDIR) = IXSYM
  949.       DIRLST(2,IXDIR) = 1
  950.       DIRLST(3,IXDIR) = 0
  951.       DIRLST(4,NDIRLS) = -IXSYM
  952.       DIRLST(5,NDIRLS) = 0
  953.       RETURN
  954.       END
  955.       SUBROUTINE  ERROR ( I )
  956. C
  957. C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> COMPILER DEPENDENT
  958. C---
  959. C--- PRINT ERROR MESSAGES
  960. C---
  961.       IMPLICIT INTEGER (A-Z)
  962. C---
  963.       COMMON /FLAGS/  FULFLG, RESEQF, PRECOF, NPLFLG, ERRFLG
  964.      9              , WARNFL, SHOWFL
  965.       DIMENSION  XXXXXX(4)
  966.       DATA       IXXXXX/200000/
  967. C---
  968.       IF( I .EQ. 99 )  GOTO  8000
  969.       GOTO ( 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15
  970.      1     ,16, 17, 18, 19, 20, 21, 22, 23, 24, 25), I
  971. 1     WRITE(6,101)
  972. 101   FORMAT(13H -E R R O R--,30HFIELD LONGER THAN 8 CHARACTERS)
  973.       GOTO  9000
  974. 2     WRITE(6,102)
  975. 102   FORMAT(13H -E R R O R--,16HBAD NUMBER FIELD)
  976.       GOTO  9000
  977. 3     WRITE(6,103)
  978. 103   FORMAT(13H -E R R O R--,25H*DECK OR *COMDECK MISSING )
  979.       GOTO  8000
  980. 4     WRITE(6,104)
  981. 104   FORMAT(13H -E R R O R--,28HPERIOD MISSING BEFORE NUMBER)
  982.       GOTO  9000
  983. 5     WRITE(6,105)
  984. 105   FORMAT(13H -E R R O R--,17HNUMBER IS MISSING)
  985.       GOTO  9000
  986. 6     WRITE(6,106)
  987. 106   FORMAT(13H -E R R O R--,18HNAME IS NOT UNIQUE)
  988.       GOTO  9000
  989. 7     WRITE(6,107)
  990. 107   FORMAT(13H -E R R O R--,12HNAME MISSING)
  991.       GOTO  9000
  992. 8     WRITE(6,108)
  993. 108   FORMAT(13H -E R R O R--,25HTHIS UPDATE DIRECTIVE NOT
  994.      1           ,33H ALLOWED IN CREATION OR AFTER *AF)
  995.       GOTO  9000
  996. 9     WRITE(6,109)
  997. 109   FORMAT(13H -E R R O R--,30HCAN*T CALL FROM WITHIN COMDECK)
  998.       GOTO  9000
  999. 10    WRITE(6,110)
  1000. 110   FORMAT(13H -E R R O R--,17HCOMDECK NOT FOUND)
  1001.       GOTO  9000
  1002. 11    WRITE(6,111)
  1003. 111   FORMAT(13H -E R R O R--,17HCAN*T CALL A DECK)
  1004.       GOTO  9000
  1005. 12    WRITE(6,112)
  1006. 112   FORMAT(13H -E R R O R--,23HCOMDECK BUFFER EXCEEDED /
  1007.      1                   ,13X,26HINCREASE // MEM(.), MMSTOR  )
  1008.       GOTO  8000
  1009. 13    WRITE(6,113)
  1010. 113   FORMAT(13H --WARNING---,14H*IDENT MISSING)
  1011.       GOTO  7000
  1012. 14    WRITE(6,114)
  1013. 114   FORMAT(13H -E R R O R--,26H*DK, *CD MUST BE AFTER *AF)
  1014.       GOTO  8000
  1015. 15    WRITE(6,115)
  1016. 115   FORMAT(13H -E R R O R--,16HNUMBER INCORRECT)
  1017.       GOTO  9000
  1018. 16    WRITE(6,116)
  1019. 116   FORMAT(13H -E R R O R--,28HCORRECTION CAPACITY EXCEEDED /
  1020.      1                   ,13X,31HINCREASE // CORTBL(5,.), MCORTB)
  1021.       GOTO  8000
  1022. 17    WRITE(6,117)
  1023. 117   FORMAT(13H -E R R O R--,28HCORRECTION CAPACITY EXCEEDED /
  1024.      1                   ,13X,31HINCREASE // MODLST(2,.), MMODLS)
  1025.       GOTO  8000
  1026. 18    WRITE(6,118)
  1027. 118   FORMAT(13H -E R R O R--,25HDECK OR COMDECK NOT FOUND)
  1028.       GOTO  9000
  1029. 19    WRITE(6,119)
  1030. 119   FORMAT(13H -E R R O R--,28HCORRECTION CAPACITY EXCEEDED /
  1031.      1                   ,13X,26HINCREASE // MEM(.), MMSTOR  )
  1032.       GOTO  8000
  1033. 20    WRITE(6,120)
  1034. 120   FORMAT(13H -E R R O R--,28HCORRECTION CAPACITY EXCEEDED /
  1035.      1                   ,13X,31HINCREASE // DIRLST(5,.), MDIRLS )
  1036.       GOTO  8000
  1037. 21    WRITE(6,121)
  1038. 121   FORMAT(13H -E R R O R--,28HOVERLAPPING CORRECTION FOUND )
  1039.       GOTO  8000
  1040. 22    WRITE(6,122)
  1041. 122   FORMAT(13H -E R R O R--,19H*D, *I, *AF MISSING)
  1042.       GOTO  9000
  1043. 23    WRITE(6,123)
  1044. 123   FORMAT(13H -E R R O R--,17HCOMDECK NOT FOUND)
  1045.       GOTO  9000
  1046. 24    WRITE(6,124)
  1047. 124   FORMAT(13H -E R R O R--)
  1048.       RETURN
  1049. 25    WRITE(6,125)
  1050. 125   FORMAT(13H -E R R O R--)
  1051.       RETURN
  1052. 7000  WARNFL = 1
  1053.       RETURN
  1054. 8000  WRITE( 6, 1003 )
  1055. 1003  FORMAT( 18H ? *** ABORTED *** )
  1056. C>>>>>>>>> *ABORT* <<<<<<<<<<
  1057. C...  TYPE  1003                                                 8-11-86
  1058.       PRINT 1003
  1059.       I = XXXXXX(IXXXXX)
  1060. 9000  ERRFLG = 1
  1061.       RETURN
  1062.       END
  1063.       SUBROUTINE  FIND ( DNSQ )
  1064. C-
  1065. C--- COPY PLIN TO PLTMP UNTIL DNSQ FOUND
  1066. C-
  1067.       IMPLICIT INTEGER (A-Z)
  1068. C---
  1069.       COMMON /DIR/    MSYMTB, NSYMTB, KSYMTB, ISYMTB
  1070.      1              , MDIRLS, NDIRLS, KDIRLS, IDIRLS
  1071.      2              , NCOMDK, NDECK , NIDENT
  1072.      3              , MMEM  , NMSTOR, NMFETC
  1073.      4              , MCORTB, NCORTB, MMODLS, NMODLS
  1074.      5              , LASTDK
  1075.       COMMON          SYMTB(7,400)  , DIRLST(5,2000)
  1076.      1              , CORTBL(5,1000), MODLST(2,1000)
  1077.      2              , MEM(20000)
  1078.       COMMON /FILES/  INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
  1079.      1              , EDTT  , PL1TMP, PL2TMP, PLTMP , PLIN
  1080.       COMMON /REC/    CALFLG, TYP, DIRNUM, SEQ, CARD4(20)
  1081.      1              , CARD4S(20)
  1082.           DIMENSION  REC(22)
  1083.               EQUIVALENCE  (DIRNUM, REC(1))
  1084. C---
  1085.       DIMENSION  DNSQ(2)
  1086. C---
  1087.       DN = DNSQ(1)
  1088.       SQ = DNSQ(2)
  1089.       DIRNUX = DIRNUM
  1090.       SEQX   = SEQ
  1091. 100   IF( SQ .NE. SEQ )  GOTO  200
  1092.       IF( DN .EQ. DIRNUM )  GOTO  900
  1093. 200    CALL  WTPL ( PLTMP )
  1094.        CALL  RDPLIN
  1095.       IF( SEQ .NE. 0 )  GOTO  100
  1096.         IF( SQ .NE. 0 )  WRITE( OUTPUT, 101 )  SYMTB(1,DIRNUX),
  1097.      1                                         SYMTB(2,DIRNUX), SEQX
  1098.      2                                  ,  SYMTB(1,DN), SYMTB(2,DN), SQ
  1099. 101     FORMAT( 28H ------------- NOW AT LINE= , 2A4, I4,
  1100.      1                22H    LOOKING FOR LINE= , 2A4, I4 )
  1101.         IF( SQ .NE. 0 )  CALL  ERROR ( 21 )
  1102. 900   RETURN
  1103.       END
  1104.       FUNCTION ISRCH(KEY,KEYLST,NKEY,NDIM)
  1105. C
  1106. C              SEARCH KEYLST(NDIM,NKEY) FOR KEY(NDIM)
  1107. C
  1108.       DIMENSION KEY(1), KEYLST(1)
  1109. C
  1110. C              SET TOP AND BOTTOM OF RANGE
  1111.       ITOP   = NKEY
  1112.       IBOT   = 0
  1113.       ISRCH  = 0
  1114. C              PRINT 902, (KEY(I),I=1,4)
  1115. C              902 FORMAT(*  LOOKING FOR *4A4)
  1116. C              DIVIDE SEARCH RANGE IN TWO
  1117.     5 IHLF   = (ITOP+IBOT)/2
  1118. C              PRINT 901,ITOP,IBOT,IHLF
  1119. C              901 FORMAT(1H ,*ITOP = *I4*  IBOT = *I4*  IHLF = *I4)
  1120. C              PRINT 903, (KEYLST(I+(IHLF-1)*NDIM),I=1,4)
  1121. C              903 FORMAT(*  COMPARING WITH *4A4)
  1122. C              COMPARE KEY(I) WITH KEYLST(I,IHLF)
  1123.       DO 10 I=1,NDIM
  1124.       I1     = I + (IHLF-1)*NDIM
  1125.       IF( KEY(I) .GT. KEYLST(I1) )  GOTO 40
  1126.       IF( KEY(I) .LT. KEYLST(I1) )  GOTO 60
  1127.    10 CONTINUE
  1128. C              EQUAL.  SET ISRCH AND RETURN
  1129.       ISRCH  = IHLF
  1130.       GO TO 100
  1131. C              KEY IS IN TOP HALF.  CHECK FOR NOT FOUND
  1132.    40 CONTINUE
  1133.       IF (ITOP .EQ. IBOT)  GO TO 100
  1134. C              RESET IBOT AND KEEP GOING
  1135.       IBOT   = IHLF + 1
  1136.       GO TO 5
  1137. C              KEY IS IN BOTTOM HALF.  CHECK FOR NOT FOUND
  1138.    60 CONTINUE
  1139.       IF (ITOP .EQ. IBOT)  GO TO 100
  1140. C              RESET ITOP AND KEEP GOING
  1141.       ITOP   = IHLF
  1142.       GO TO 5
  1143.   100 CONTINUE
  1144.       RETURN
  1145.       END
  1146.       SUBROUTINE  MEMFET
  1147. C-
  1148. C--- FETCH A CARD FROM MEM TO REC ARRAY
  1149. C-
  1150.       IMPLICIT INTEGER (A-Z)
  1151. C---
  1152.       COMMON /DIR/    MSYMTB, NSYMTB, KSYMTB, ISYMTB
  1153.      1              , MDIRLS, NDIRLS, KDIRLS, IDIRLS
  1154.      2              , NCOMDK, NDECK , NIDENT
  1155.      3              , MMEM  , NMSTOR, NMFETC
  1156.      4              , MCORTB, NCORTB, MMODLS, NMODLS
  1157.      5              , LASTDK
  1158.       COMMON          SYMTB(7,400)  , DIRLST(5,2000)
  1159.      1              , CORTBL(5,1000), MODLST(2,1000)
  1160.      2              , MEM(20000)
  1161.       COMMON /REC/    CALFLG, TYP, DIRNUM, SEQ, CARD4(20)
  1162.      1              , CARD4S(20)
  1163.           DIMENSION  REC(22)
  1164.               EQUIVALENCE  (DIRNUM, REC(1))
  1165. C---
  1166.       CALFLG = 0
  1167.       TYP = MEM(NMFETC)
  1168.       IF( TYP .NE. 1 )  GOTO  330
  1169.           DO  320  I = 1 , 20
  1170.           IM = NMFETC + I
  1171. 320       REC(I+2) = MEM(IM)
  1172.           NMFETC = NMFETC + 21
  1173.           GOTO  900
  1174. 330   IF( TYP .NE. 2 )  GOTO  340
  1175.           CALFLG = MEM(NMFETC+1)
  1176.           NMFETC = NMFETC + 2
  1177.           GOTO  900
  1178. 340     DIRNUM=MEM(NMFETC+1)
  1179.         NMFETC = NMFETC + 2
  1180. 900   RETURN
  1181.       END
  1182.       SUBROUTINE  MEMSTO
  1183. C-
  1184. C--- STORE CORRECTION CARDS IN MEMORY
  1185. C-
  1186.       IMPLICIT INTEGER (A-Z)
  1187. C---
  1188.       COMMON /DIR/    MSYMTB, NSYMTB, KSYMTB, ISYMTB
  1189.      1              , MDIRLS, NDIRLS, KDIRLS, IDIRLS
  1190.      2              , NCOMDK, NDECK , NIDENT
  1191.      3              , MMEM  , NMSTOR, NMFETC
  1192.      4              , MCORTB, NCORTB, MMODLS, NMODLS
  1193.      5              , LASTDK
  1194.       COMMON          SYMTB(7,400)  , DIRLST(5,2000)
  1195.      1              , CORTBL(5,1000), MODLST(2,1000)
  1196.      2              , MEM(20000)
  1197.       COMMON /REC/    CALFLG, TYP, DIRNUM, SEQ, CARD4(20)
  1198.      1              , CARD4S(20)
  1199.           DIMENSION  REC(22)
  1200.               EQUIVALENCE  (DIRNUM, REC(1))
  1201. C---
  1202.           IF( NMSTOR+21 .GT. MMEM )  CALL  ERROR ( 19 )
  1203.           MEM(NMSTOR+1) = TYP
  1204.       IF( TYP .NE. 1 ) GOTO  330
  1205.             DO  320  I = 1 , 20
  1206.             IM = NMSTOR + I
  1207.             MEM(IM+1) = CARD4(I)
  1208. 320         CONTINUE
  1209.             NMSTOR = NMSTOR + 21
  1210.                 GOTO  390
  1211. 330   IF( TYP .NE. 2 )  GOTO  340
  1212.             MEM(NMSTOR+2) = CALFLG
  1213.             NMSTOR = NMSTOR+2
  1214.                 GOTO  390
  1215. 340         MEM(NMSTOR+2) = DIRNUM
  1216.             NMSTOR = NMSTOR + 2
  1217. 390   RETURN
  1218.       END
  1219.       SUBROUTINE  NUMCOL ( NUM )
  1220. C---
  1221. C--- COLLECT NUMBER FIELD TERMINATED BY <,>,< >
  1222. C---
  1223.       IMPLICIT INTEGER (A-Z)
  1224.       COMMON /CARD/   CARD(80), JCARD, LINCNT, PRTFLG, ICH
  1225.      1               ,IFL(8)  , BKSPFL
  1226.       COMMON /CHARS/  STAR, BLNK, COMA, PERD, SLAS
  1227. C---
  1228.       DIMENSION  N09(10)
  1229. C---
  1230.       DATA  N09/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
  1231. C---
  1232.       NUM    = 0
  1233.       IF( (JCARD.GE.80).OR.(ICH.NE.PERD))  GOTO 800
  1234. 100   JCARD = JCARD + 1
  1235.       IF( JCARD .GT. 80 )  GOTO 250
  1236.         ICH = CARD(JCARD)
  1237.         IF( (ICH.EQ.BLNK).OR.(ICH.EQ.COMA) )  GOTO 300
  1238. C------ CK IF NUMBER
  1239.             DO  220  I = 1 , 10
  1240.             IF( ICH .EQ. N09(I) )  GOTO  230
  1241. 220         CONTINUE
  1242.            CALL  ERROR ( 2 )
  1243.           GOTO  900
  1244. 230     NUM = 10*NUM + I-1
  1245.         GOTO  100
  1246. 250   ICH = BLNK
  1247. 300   CONTINUE
  1248. C------ GIVE ERROR MSG IF NUMBER IS MISSING
  1249.       IF( NUM .EQ. 0 )  CALL  ERROR ( 5 )
  1250.       RETURN
  1251. C------ PERIOD MISSING BEFORE NUMBER
  1252. 800   CALL  ERROR ( 4 )
  1253. 900   RETURN
  1254.       END
  1255.       SUBROUTINE  OPGET
  1256. C---
  1257. C--- SCAN OP FIELD AND GET OP NUMBER
  1258. C---
  1259.       IMPLICIT INTEGER (A-Z)
  1260. C---
  1261.       COMMON /CARD/   CARD(80), JCARD, LINCNT, PRTFLG, ICH
  1262.      1               ,IFL(8)  , BKSPFL
  1263.       COMMON /CHARS/  STAR, BLNK, COMA, PERD, SLAS
  1264.       COMMON /OPTBL/  OPTBL(5,11), NOPTBL, JOP, OPARG
  1265.       COMMON /OP/     IOP(2), ID1(2), ND1, ID2(2), ND2, NOP, OP
  1266. C---
  1267.       DIMENSION  IFLD(2)
  1268. C---
  1269.       JCARD = 1
  1270.        CALL  CRAK2 ( IFLD, 0 )
  1271.       OP = 0
  1272.       IF( IFLD(1) .EQ. BLNK )  GOTO  900
  1273.         DO  200  I = 1 , NOPTBL
  1274.         IF( (IFLD(1).EQ.OPTBL(1,I)).OR.
  1275.      1      (IFLD(1).EQ.OPTBL(2,I)) )  GOTO  300
  1276. 200     CONTINUE
  1277.       GOTO  900
  1278. 300   OP = OPTBL(4,I)
  1279.       OPARG = OPTBL(5,I)
  1280.       JOP = I
  1281. 900   RETURN
  1282.       END
  1283.       SUBROUTINE  OPGET2
  1284. C---
  1285. C--- GET THE TWO OPERANDS OF UPDATE COMMAND
  1286. C---
  1287.       IMPLICIT INTEGER (A-Z)
  1288. C---
  1289.       COMMON /CARD/   CARD(80), JCARD, LINCNT, PRTFLG, ICH
  1290.      1               ,IFL(8)  , BKSPFL
  1291.       COMMON /CHARS/  STAR, BLNK, COMA, PERD, SLAS
  1292.       COMMON /OPTBL/  OPTBL(5,11), NOPTBL, JOP, OPARG
  1293.       COMMON /OP/     IOP(2), ID1(2), ND1, ID2(2), ND2, NOP, OP
  1294. C---
  1295.       DIMENSION  N09(10)
  1296. C---
  1297.       DATA  N09/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
  1298. C---
  1299.       IF( OPARG .EQ. 0 )  GOTO 900
  1300.       IOPARG = IABS(OPARG)
  1301.       SOPARG = OPARG / IOPARG
  1302.        CALL CRAK2 ( ID1, 1 )
  1303.       IF( SOPARG .LT. 0 )  CALL  NUMCOL ( ND1 )
  1304.       IF( IOPARG .EQ. 1 )  GOTO  600
  1305.         IF( ICH .NE. COMA )  GOTO  600
  1306.            CALL  CRAK2 ( ID2, 1 )
  1307.           IF( SOPARG .GE. 0 )  GOTO  900
  1308.               DO  300  I = 1 , 10
  1309.               IF( IFL(1) .EQ. N09(I) )  GOTO  400
  1310. 300           CONTINUE
  1311.             GOTO  500
  1312. 400             DO  420  I = 1 , 8
  1313.                 CARD(I+71) = IFL(I)
  1314. 420             CONTINUE
  1315.               CARD(80) = BLNK
  1316.               JCARD = 71
  1317.               ICH   = PERD
  1318.               ID2(1) = ID1(1)
  1319.               ID2(2) = ID1(2)
  1320. 500          CALL  NUMCOL ( ND2 )
  1321.           GOTO  900
  1322. 600   ID2(1) = BLNK
  1323.       ND2 = -1
  1324. 900   RETURN
  1325.       END
  1326.       SUBROUTINE  OPLRD
  1327. C---
  1328. C--- READ OLDPL DIRECTORY
  1329. C---
  1330.       IMPLICIT INTEGER (A-Z)
  1331. C---
  1332.       COMMON /DIR/    MSYMTB, NSYMTB, KSYMTB, ISYMTB
  1333.      1              , MDIRLS, NDIRLS, KDIRLS, IDIRLS
  1334.      2              , NCOMDK, NDECK , NIDENT
  1335.      3              , MMEM  , NMSTOR, NMFETC
  1336.      4              , MCORTB, NCORTB, MMODLS, NMODLS
  1337.      5              , LASTDK
  1338.       COMMON          SYMTB(7,400)  , DIRLST(5,2000)
  1339.      1              , CORTBL(5,1000), MODLST(2,1000)
  1340.      2              , MEM(20000)
  1341.       COMMON /FILES/  INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
  1342.      1              , EDTT  , PL1TMP, PL2TMP, PLTMP , PLIN
  1343. C---
  1344.       READ(OLDPL ,1010) NCOMDK, NDECK, NIDENT, NDIRLS
  1345. 1010  FORMAT( 3X,I4,3X,I4,3X,I4,3X,I4 )
  1346.       NSYMTB = NCOMDK + NDECK + NIDENT
  1347.       READ(OLDPL ,1007)  ((SYMTB(I,J),  I=1,5), J=1,NSYMTB)
  1348. 1007  FORMAT( 1X,2A4,I2,I5,I4, 1X,2A4,I2,I5,I4, 1X,2A4,I2,I5,I4,
  1349.      1        1X,2A4,I2,I5,I4 )
  1350.       READ(OLDPL ,1008)  ((DIRLST(I,J), I=1,3), J=1,NDIRLS)
  1351. 1008  FORMAT( I4,2I5, I4,2I5, I4,2I5, I4,2I5, I4,2I5 )
  1352. C------
  1353.         DO  100  I = 1 , NSYMTB
  1354.         IF( IABS( SYMTB(3,I) ) .EQ. 1 )  LASTDK = I
  1355.         SYMTB(6,I) = 0
  1356.         SYMTB(7,I) = I
  1357. 100     CONTINUE
  1358. C------ FILL THE BACK POINTER IN DIRLST
  1359.         DO  200  I = 1 , NDIRLS
  1360.         DIRLST(4,I) = 0
  1361.         DIRLST(5,I) = 0
  1362. 200     CONTINUE
  1363.       IF( NSYMTB .LT. 2 )  GOTO  350
  1364.         DO  300  I = 2 , NSYMTB
  1365.         J = SYMTB(5,I)
  1366.         DIRLST(4,J-1) = -(I-1)
  1367. 300     CONTINUE
  1368. 350   DIRLST(4,NDIRLS) = - LASTDK
  1369. C------ FILL NEXT ENTRIES IN DIRLST
  1370.         DO  400  I = 1 , NDIRLS
  1371.         IF( DIRLST(4,I) .EQ. 0 )  DIRLST(4,I) = I+1
  1372. 400     CONTINUE
  1373. C------
  1374.       RETURN
  1375.       END
  1376.       SUBROUTINE PRECMP(REC,LINE1,LINE2,NL)
  1377. C
  1378. C              PRGEDT EDITS SOURCE FILES, REPLACING NAMES WITHIN<> WITH A
  1379. C              POSITION IN THE LINE.
  1380. C
  1381. C              IA CONTAINS THE INPUT LINE
  1382. C              IB CONTAINS THE OUTPUT LINE
  1383. C              ID SAVES COLUMNS 73-90 OF IA
  1384. C              ICA STORES THE PRESENT POSITION IN IA
  1385. C              ICB STORES THE PRESENT POSITION IN IB
  1386. C
  1387.       IMPLICIT INTEGER (A-Z)
  1388. C
  1389.       COMMON /FILES/  INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
  1390.      1              , EDTT  , PL1TMP, PL2TMP, PLTMP , PLIN
  1391.       COMMON /FLAGS/  FULFLG, RESEQF, PRECOF, NPLFLG, ERRFLG
  1392.      9              , WARNFL, SHOWFL
  1393. C
  1394.       DIMENSION NAME(2),REC(20),LINE1(20),LINE2(20),CARD(80)
  1395.       DIMENSION IA(80), IB(144), INAM(4,1500), ITXT(4,1500),
  1396.      1          KEY(16), KEY4(4), IREPL(16), ID( 8), IB2(72), IREPL2(20)
  1397. C
  1398.       EQUIVALENCE (IA(1), CARD(1)), (IB2(1), IB(1))
  1399. C
  1400.       DATA NENTS/0/
  1401.       DATA ITERMB, ITERME, ICMNT, ICNTNU, IBLNK /
  1402.      1 1H<, 1H>, 1HC, 1H., 1H /
  1403.       DATA IHI, IAT, IRP / 1HI, 1H@, 1H) /
  1404.       DATA IREPL2(2), IREPL2(3), IREPL2(4)
  1405.      1 / 1HA, 1H(, 1HI /
  1406. C
  1407. C
  1408.            IF (   NENTS     .GT.       0)                   GO TO    1
  1409. C
  1410. C     I N I T I A L I Z A T I O N
  1411. C
  1412.          IERR =       0
  1413.        REWIND       EDTT
  1414. C              INITIALIZE START OF OVERFLOW LINE
  1415.       DO 5 I = 73,77
  1416.     5 IB(I)  = IBLNK
  1417.       IB(78) = ICNTNU
  1418. C              READ IN EDIT TABLE
  1419.       READ(EDTT, END=90000)  NENTS, ((INAM(I,J), I=1,4), J=1,NENTS),
  1420.      1                  ((ITXT(I,J),I=1,4),J=1,NENTS)
  1421.        REWIND       EDTT
  1422. C
  1423.     1 CONTINUE
  1424.       LINE1(19) = IBLNK
  1425.       LINE1(20) = IBLNK
  1426.       LINE2(19) = IBLNK
  1427.       LINE2(20) = IBLNK
  1428.       CALL A4A1(REC,CARD,20)
  1429.       IF(IA(1) .NE. ICMNT)  GOTO 3
  1430.       NL = 1
  1431.       DO 4 I=1,20
  1432.     4 LINE1(I) = REC(I)
  1433.       RETURN
  1434.     3       J =       0
  1435.       DO  2 I =  73, 80
  1436.             J =   J + 1
  1437.         ID(J) =   IA(I)
  1438.     2          CONTINUE
  1439. C
  1440. C              LOOP THROUGH IA LOOKING FOR <
  1441.    20 ICA    = 0
  1442.       ICB    = 0
  1443. C              BLANK OUT IB
  1444.       DO 25 I=1,72
  1445.    25 IB(I)  = IBLNK
  1446.       DO 26 I=79,144
  1447.    26 IB(I)  = IBLNK
  1448.    30 ICA    = ICA + 1
  1449.       IF (ICA .EQ. 73)  GO TO 100
  1450.       IF (IA(ICA) .EQ.ITERMB)  GO TO 200
  1451. C              DID NOT FIND <  --- SET IB = IA
  1452.       ICB    = ICB + 1
  1453. C              CHECK FOR OVERFLOW
  1454.       IF (ICB .EQ. 73)  ICB = ICB + 6
  1455.       IB(ICB) = IA(ICA)
  1456.       GO TO 30
  1457. C              END OF LINE.  CHECK FOR NUM OF LINES AND RETURN
  1458. C
  1459.   100 NL = 1
  1460.       DO 111 I=79,144
  1461.       IF(IB(I) .NE. IBLNK) NL = 2
  1462.   111 CONTINUE
  1463.       CALL A1A4(IB,LINE1,18)
  1464.       IF(NL .EQ. 2)  CALL A1A4(IB(73),LINE2,18)
  1465.       RETURN
  1466. C
  1467. C              FOUND <.  LOOP THROUGH IA LOOKING FOR >
  1468.   200 KYC    = 0
  1469.       IATFLG = 0
  1470. C              CHECK FOR AT SIGN
  1471.       IF (IA(ICA+1) .NE. IAT)  GO TO 210
  1472.       ICA    = ICA + 1
  1473.       IATFLG = 1
  1474.   210 ICA    = ICA + 1
  1475.       KYC    = KYC + 1
  1476. C              IF ICA GREATER THAN 72 --- ERROR
  1477.       IF (ICA .GT. 72)  GO TO 700
  1478. C              IF KYC GREATER THAN 16 --- ERROR
  1479.       IF (IA(ICA) .EQ. ITERME)  GO TO 220
  1480.       IF (KYC .GT. 16)  GO TO 710
  1481. C              SET KEY
  1482.       KEY(KYC) = IA(ICA)
  1483.       GO TO 210
  1484.   220 CONTINUE
  1485. C              FOUND > .  ZERO OUT REST OF KEY
  1486.       IF(KYC .GT. 16)  GOTO 2002
  1487.       DO 225 I=KYC,16
  1488. 225   KEY(I) = IBLNK
  1489.  2002 CONTINUE
  1490. C              ENCODE KEY ONTO KEY4 USING A4 FORMAT
  1491.       CALL A1A4(KEY,KEY4,4)
  1492. C              SEARCH FOR KEY4 IN INAM
  1493.       IX     = ISRCH(KEY4,INAM,NENTS,4)
  1494. C              COULD NOT FIND --- ERROR
  1495.       IF (IX .EQ. 0)  GO TO 720
  1496. C              MOVE THE REPLACEMENT TEXT INTO IREPL IN A1 FORMAT
  1497.       CALL A4A1(ITXT(1,IX),IREPL,4)
  1498. C              CHECK FOR AT SIGN
  1499.       IF (IATFLG .EQ. 0)  GO TO 229
  1500. C              THERE WAS AN AT SIGN.  FILL IREPL2
  1501.       IREPL2(1) = IREPL(1)
  1502.       DO 226 I=2,14
  1503.   226 IREPL2(I+3) = IREPL(I)
  1504. C              MOVE IREPL2 INTO IB, LEAVING OFF TRAILING ZEROS
  1505.       DO 227 I=1,18
  1506.       IF( IREPL2(I) .EQ. IBLNK )  GOTO 228
  1507.       ICB    = ICB + 1
  1508.       IF (ICB .EQ. 73)  ICB = ICB + 6
  1509.   227 IB(ICB) = IREPL2(I)
  1510.       GO TO 30
  1511.   228 ICB    = ICB + 1
  1512.       IF (ICB .EQ. 73) ICB = ICB + 6
  1513.       IB(ICB) = IRP
  1514.       GO TO 30
  1515.   229 CONTINUE
  1516. C              MOVE IREPL INTO IB, LEAVING OFF THE TRAILING ZEROS
  1517.       DO 230 I=1,14
  1518.       IF( IREPL(I) .EQ. IBLNK )  GOTO 30
  1519.       ICB    = ICB + 1
  1520.       IF (ICB .EQ. 73)  ICB = ICB + 6
  1521.   230 IB(ICB) = IREPL(I)
  1522. C              CONTINUE LOOPING THROUGH IA
  1523.       GO TO 30
  1524. C              ERROR PROCESSING
  1525.   700 CONTINUE
  1526.  1001  FORMAT (    80A1)
  1527.         WRITE (  OUTPUT,     701)      IA
  1528.   701 FORMAT(1H ,46HERROR --- FOUND END OF LINE BEFORE>.  THE LINE
  1529.      1, 9H WAS ---  /1H ,90A1/)
  1530.       IERR   = 1
  1531.       WRITE (OUTPUT,1001) IA
  1532.       GO TO 10
  1533.   710 CONTINUE
  1534.         WRITE (  OUTPUT,     711)     KEY,      IA
  1535.   711 FORMAT(1H ,52HERROR --- NAME WITHIN <> GREATER THAN 16 CHARACTERS.
  1536.      1,14HTHE NAME IS -  ,16A1,16H  THE LINE IS -  /1H ,90A1/)
  1537.       IERR   = 1
  1538.       WRITE (OUTPUT,1001) IA
  1539.       GO TO 10
  1540.   720 CONTINUE
  1541.         WRITE (  OUTPUT,     721)     KEY,      IA
  1542.   721 FORMAT(1H ,41HERROR --- NAME NOT FOUND IN EDIT TABLE.  
  1543.      1,14HTHE NAME IS -  ,16A1,16H  THE LINE IS -  /1H ,90A1/)
  1544.       IERR   = 1
  1545.       ICABS  = ICA - KYC - IATFLG
  1546.       DO 724 I=ICABS,ICA
  1547.       ICB    = ICB + 1
  1548.       IF (ICB .EQ. 73)  ICB = ICB + 6
  1549.       IB(ICB) = IA(I)
  1550.   724 CONTINUE
  1551.       GO TO 30
  1552. 90000 WRITE(OUTPUT,90001)
  1553. 90001 FORMAT( 40H ***ERROR*** (UPDATE)  FILE EDTT MISSING )
  1554.       PRECOF = 0
  1555.    10  RETURN
  1556.       END
  1557.       SUBROUTINE  RDPLIN
  1558. C
  1559. C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>  COMPILER DEPENDENT
  1560. C-
  1561. C--- READ ONE LINE FROM PLIN
  1562. C-
  1563.       IMPLICIT INTEGER (A-Z)
  1564. C---
  1565.       COMMON /DIR/    MSYMTB, NSYMTB, KSYMTB, ISYMTB
  1566.      1              , MDIRLS, NDIRLS, KDIRLS, IDIRLS
  1567.      2              , NCOMDK, NDECK , NIDENT
  1568.      3              , MMEM  , NMSTOR, NMFETC
  1569.      4              , MCORTB, NCORTB, MMODLS, NMODLS
  1570.      5              , LASTDK
  1571.       COMMON          SYMTB(7,400)  , DIRLST(5,2000)
  1572.      1              , CORTBL(5,1000), MODLST(2,1000)
  1573.      2              , MEM(20000)
  1574.       COMMON /DKFLG/  DKFLG
  1575.       COMMON /FILES/  INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
  1576.      1              , EDTT  , PL1TMP, PL2TMP, PLTMP , PLIN
  1577.       COMMON /REC/    CALFLG, TYP, DIRNUM, SEQ, CARD4(20)
  1578.      1              , CARD4S(20)
  1579.           DIMENSION  REC(22)
  1580.               EQUIVALENCE  (DIRNUM, REC(1))
  1581. C---
  1582. C>>>>>>>>> *EOF* <<<<<<<<<
  1583.       READ( PLIN, 1009, END=800 )  TYP, REC
  1584. 1009  FORMAT( I2,I4,I5,1X,20A4 )
  1585.       DIRNUM = SYMTB(7,DIRNUM)
  1586.       IF( TYP .EQ. 3 )  DKFLG = DIRNUM
  1587.       CALFLG = 0
  1588.       IF( IABS( TYP ) .NE. 2 )  GOTO  900
  1589.           READ( PLIN, 1014 )  CALFLG
  1590. 1014  FORMAT( 4X,I4 )
  1591.           CALFLG = SYMTB(7,CALFLG)
  1592.           IF( DKFLG .EQ. 0 )  GOTO  900
  1593.             IF( SYMTB(4,CALFLG) .LT. 0 )
  1594.      1              SYMTB(4,DKFLG) = - IABS( SYMTB(4,DKFLG) )
  1595. 900   RETURN
  1596. 800   SEQ = 0
  1597.       GOTO  900
  1598.       END
  1599.       SUBROUTINE  RESEQ
  1600. C---
  1601. C------ RESEQUENCE (PLIN) INTO (PLTMP)
  1602. C---
  1603.       IMPLICIT INTEGER (A-Z)
  1604. C---
  1605.       COMMON /DIR/    MSYMTB, NSYMTB, KSYMTB, ISYMTB
  1606.      1              , MDIRLS, NDIRLS, KDIRLS, IDIRLS
  1607.      2              , NCOMDK, NDECK , NIDENT
  1608.      3              , MMEM  , NMSTOR, NMFETC
  1609.      4              , MCORTB, NCORTB, MMODLS, NMODLS
  1610.      5              , LASTDK
  1611.       COMMON          SYMTB(7,400)  , DIRLST(5,2000)
  1612.      1              , CORTBL(5,1000), MODLST(2,1000)
  1613.      2              , MEM(20000)
  1614.       COMMON /DKFLG/  DKFLG
  1615.       COMMON /FILES/  INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
  1616.      1              , EDTT  , PL1TMP, PL2TMP, PLTMP , PLIN
  1617.       COMMON /REC/    CALFLG, TYP, DIRNUM, SEQ, CARD4(20)
  1618.      1              , CARD4S(20)
  1619.           DIMENSION  REC(22)
  1620.               EQUIVALENCE  (DIRNUM, REC(1))
  1621. C---
  1622. C------ DISABLE COMPILE FLAG SETTING PART IN RDPLIN
  1623.       DKFLG = 0
  1624.       NDIRLS = 0
  1625. 200    CALL  RDPLIN
  1626.       IF( SEQ .EQ. 0 )  GOTO  900
  1627.         ITYP = IABS ( TYP )
  1628.         GOTO ( 12, 12, 34, 34 ), ITYP
  1629. C------ *CA, DATA
  1630. 12      IF( TYP .LT. 0 )  GOTO  200
  1631. 300         NEWSEQ = NEWSEQ + 1
  1632.             SEQ    = NEWSEQ
  1633.             SYMTB(4,JSYMTB) = NEWSEQ
  1634.             DIRLST(3,NDIRLS) = NEWSEQ
  1635.             DIRNUM = JSYMTB
  1636.              CALL  WTPL ( PLTMP )
  1637.             GOTO  200
  1638. C------ *CD, *DK
  1639. 34      NEWSEQ = 0
  1640.         JSYMTB = DIRNUM
  1641.         NDIRLS = NDIRLS + 1
  1642.         DIRLST(1,NDIRLS) = JSYMTB
  1643.         DIRLST(2,NDIRLS) = 1
  1644.         DIRLST(3,NDIRLS) = 1
  1645.         DIRLST(4,NDIRLS) = -JSYMTB
  1646.         GOTO  300
  1647. C------ EOF ON PLIN
  1648. 900   NSYMTB = JSYMTB
  1649.       DO  920  I = 1 , NSYMTB
  1650.       SYMTB(7,I) = I
  1651. 920   CONTINUE
  1652.       RETURN
  1653.       END
  1654.       SUBROUTINE  SYMENT ( SYMTYP, SYMERR )
  1655. C---
  1656. C--- ENTER SYMBOL IN SYMBOL TABLE
  1657. C---
  1658.       IMPLICIT INTEGER (A-Z)
  1659. C---
  1660.       COMMON /CHARS/  STAR, BLNK, COMA, PERD, SLAS
  1661.       COMMON /DIR/    MSYMTB, NSYMTB, KSYMTB, ISYMTB
  1662.      1              , MDIRLS, NDIRLS, KDIRLS, IDIRLS
  1663.      2              , NCOMDK, NDECK , NIDENT
  1664.      3              , MMEM  , NMSTOR, NMFETC
  1665.      4              , MCORTB, NCORTB, MMODLS, NMODLS
  1666.      5              , LASTDK
  1667.       COMMON          SYMTB(7,400)  , DIRLST(5,2000)
  1668.      1              , CORTBL(5,1000), MODLST(2,1000)
  1669.      2              , MEM(20000)
  1670.       COMMON /OP/     IOP(2), ID1(2), ND1, ID2(2), ND2, NOP, OP
  1671. C---
  1672.       SYMERR = 0
  1673.       IF( ID1(2) .EQ. -1 )  GOTO  850
  1674.       IF( ID1(1) .EQ. BLNK )  GOTO  8007
  1675. C------ SEARCH SYMBOL TABLE
  1676.       IF( NSYMTB .EQ. 0 )  GOTO  300
  1677.           DO  200  I = 1 , NSYMTB
  1678.           IF( ID1(1) .NE. SYMTB(1,I) )  GOTO  200
  1679.           IF( ID1(2) .EQ. SYMTB(2,I) )  GOTO  8006
  1680. 200       CONTINUE
  1681. 300   NSYMTB = NSYMTB + 1
  1682.       ISYMTB = NSYMTB
  1683.       SYMTB(1,NSYMTB) = ID1(1)
  1684.       SYMTB(2,NSYMTB) = ID1(2)
  1685.       SYMTB(3,NSYMTB) = SYMTYP
  1686.       SYMTB(4,NSYMTB) = 0
  1687.       SYMTB(5,NSYMTB) = 0
  1688.       SYMTB(6,NSYMTB) = 0
  1689.       SYMTB(7,NSYMTB) = NSYMTB
  1690.       GOTO  900
  1691. C------ NAME IS NOT UNIQUE
  1692. 8006   CALL  ERROR ( 6 )
  1693.       SYMERR = 1
  1694.       GOTO  880
  1695. C------ NAME MISSING
  1696. 8007   CALL  ERROR ( 7 )
  1697. 850   SYMERR = 2
  1698. 880   ISYMTB = 0
  1699. 900   RETURN
  1700.       END
  1701.       SUBROUTINE  SYMSRC ( SYM, ISYM )
  1702. C---
  1703. C--- SEARCH SYMBOL TABLE FOR SYM(1-2)
  1704. C---
  1705.       IMPLICIT INTEGER (A-Z)
  1706. C---
  1707.       COMMON /DIR/    MSYMTB, NSYMTB, KSYMTB, ISYMTB
  1708.      1              , MDIRLS, NDIRLS, KDIRLS, IDIRLS
  1709.      2              , NCOMDK, NDECK , NIDENT
  1710.      3              , MMEM  , NMSTOR, NMFETC
  1711.      4              , MCORTB, NCORTB, MMODLS, NMODLS
  1712.      5              , LASTDK
  1713.       COMMON          SYMTB(7,400)  , DIRLST(5,2000)
  1714.      1              , CORTBL(5,1000), MODLST(2,1000)
  1715.      2              , MEM(20000)
  1716. C---
  1717.       DIMENSION  SYM(2)
  1718. C---
  1719.       IF( NSYMTB .EQ. 0 )  GOTO  800
  1720.           DO  200  I = 1 , NSYMTB
  1721.           IF( SYM(1) .NE. SYMTB(1,I) )  GOTO  200
  1722.           IF( SYM(2) .EQ. SYMTB(2,I) )  GOTO  400
  1723. 200       CONTINUE
  1724. 800     I = 0
  1725. 400   ISYM = I
  1726.       RETURN
  1727.       END
  1728.       SUBROUTINE  WNEWPL
  1729. C---
  1730. C------ WRITE NEWPL AND COMPILE FILES
  1731. C---
  1732.       IMPLICIT INTEGER (A-Z)
  1733. C---
  1734.       COMMON /DIR/    MSYMTB, NSYMTB, KSYMTB, ISYMTB
  1735.      1              , MDIRLS, NDIRLS, KDIRLS, IDIRLS
  1736.      2              , NCOMDK, NDECK , NIDENT
  1737.      3              , MMEM  , NMSTOR, NMFETC
  1738.      4              , MCORTB, NCORTB, MMODLS, NMODLS
  1739.      5              , LASTDK
  1740.       COMMON          SYMTB(7,400)  , DIRLST(5,2000)
  1741.      1              , CORTBL(5,1000), MODLST(2,1000)
  1742.      2              , MEM(20000)
  1743.       COMMON /DKFLG/  DKFLG
  1744.       COMMON /FILES/  INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
  1745.      1              , EDTT  , PL1TMP, PL2TMP, PLTMP , PLIN
  1746.       COMMON /FLAGS/  FULFLG, RESEQF, PRECOF, NPLFLG, ERRFLG
  1747.      9              , WARNFL, SHOWFL
  1748.       COMMON /REC/    CALFLG, TYP, DIRNUM, SEQ, CARD4(20)
  1749.      1              , CARD4S(20)
  1750.           DIMENSION  REC(22)
  1751.               EQUIVALENCE  (DIRNUM, REC(1))
  1752. C---
  1753.       DIMENSION  CDIDDK(3)
  1754.            DATA  CDIDDK/2HCD, 2HID, 2HDK/
  1755. C------ DISABLE COMPILE FLAG SETTING IN RDPLIN
  1756.       DKFLG = 0
  1757.       REWIND  COMPIL
  1758. C---
  1759.       IF( NPLFLG .EQ. 1 )  NPLFLG = FULFLG
  1760.       IF( (ERRFLG + WARNFL) .NE. 0 )  NPLFLG = 0
  1761. C---
  1762.       NMSTOR = 0
  1763.       IF( NPLFLG .NE. 0 )  REWIND  NEWPL
  1764.       IF( NPLFLG .NE. 0 )
  1765.      1          WRITE(NEWPL ,1006) NCOMDK, NDECK, NIDENT, NDIRLS
  1766. 1006  FORMAT( 10H DIRECTORY,/,3H CD,I4,3H DK,I4,3H ID,I4,3H LM,I4 )
  1767.           DO  110  I = 1 , NSYMTB
  1768.           SYMTB(6,I) = SYMTB(4,I)
  1769.           SYMTB(4,I) = IABS ( SYMTB(4,I) )
  1770. 110       CONTINUE
  1771.       IF( NPLFLG .NE. 0 )
  1772.      1          WRITE(NEWPL ,1007)  ((SYMTB(I,J),  I=1,5), J=1,NSYMTB)
  1773. 1007  FORMAT( 1X,2A4,I2,I5,I4, 1X,2A4,I2,I5,I4, 1X,2A4,I2,I5,I4,
  1774.      1        1X,2A4,I2,I5,I4 )
  1775.             DO  120  I = 1 , NSYMTB
  1776.             SYMTB(5,I) = SYMTB(3,I)
  1777.             J = SYMTB(3,I)
  1778.             SYMTB(3,I) = CDIDDK(J+2)
  1779. 120         CONTINUE
  1780.       WRITE(OUTPUT,1019) NCOMDK, NDECK, NIDENT
  1781. 1019  FORMAT( 10H DIRECTORY,/,1X,I4,10H COMDECKS,,I5,7H DECKS,
  1782.      1                          ,I5,7H IDENTS)
  1783.       WRITE(OUTPUT,1018)  ((SYMTB(I,J),  I=1,4), J=1,NSYMTB)
  1784. 1018  FORMAT( 1X,2A4,2X,A2,I5, 5X,2A4,2X,A2,I5
  1785.      1      , 5X,2A4,2X,A2,I5, 5X,2A4,2X,A2,I5 )
  1786.       IF( NPLFLG .NE. 0 )
  1787.      1          WRITE(NEWPL ,1008)  ((DIRLST(I,J), I=1,3), J=1,NDIRLS)
  1788. 1008  FORMAT( I4,2I5, I4,2I5, I4,2I5, I4,2I5, I4,2I5 )
  1789. C---
  1790.             DO  200  I = 1 , NSYMTB
  1791.             SYMTB(3,I) = SYMTB(5,I)
  1792.             SYMTB(4,I) = SYMTB(6,I)
  1793.             SYMTB(5,I) = 0
  1794. 200         SYMTB(6,I) = 0
  1795. C------ TRANSFER PLIN TO NEWPL
  1796. 2000   CALL  RDPLIN
  1797.           IF( SEQ .EQ. 0 )  GOTO  9000
  1798.               IF( NPLFLG .NE. 0 )
  1799.      1             CALL  WTPL ( NEWPL )
  1800. C.......... DO NOTHING IF INACTIVE
  1801.       IF( TYP .LT. 0 )  GOTO  2000
  1802.         GOTO  (2100, 2200, 2300, 2400, 2500) , TYP
  1803. C------ DATA
  1804. 2100  IF( CDFLG .NE. 0 )  GOTO  2150
  1805.       IF( CFFL  .NE. 0 )  CALL  COMPWT ( REC )
  1806.       GOTO  2000
  1807. 2150  IF( NMSTOR+22 .GT. MMEM )  CALL  ERROR ( 12 )
  1808.       SYMTB(6,CDFLG) = SYMTB(6,CDFLG) + 1
  1809.           DO  2160  I = 1 , 22
  1810.           II = NMSTOR + I
  1811. 2160      MEM(II) = REC(I)
  1812.       NMSTOR = NMSTOR + 22
  1813.       GOTO  2000
  1814. C------ *CA
  1815. 2200  IF( CFFL .EQ. 0 )  GOTO  2000
  1816.       PTR = SYMTB(5,CALFLG)
  1817.       N   = SYMTB(6,CALFLG)
  1818.       IF( PTR .EQ. 0 )  GOTO  2280
  1819.       IF( N .EQ. 0 )  GOTO  2000
  1820.           DO  2220  I = 1 , N
  1821.            CALL  COMPWT ( MEM(PTR) )
  1822.           PTR = PTR + 22
  1823. 2220      CONTINUE
  1824.       GOTO  2000
  1825. 2280   CALL  ERROR ( 23 )
  1826.       WRITE( OUTPUT, 1017 )  (SYMTB(I,CALFLG), I=1,2)
  1827. 1017  FORMAT(13X,8HCOMDECK ,2A4,27H MUST BE PREVIOUSLY DEFINED)
  1828.       GOTO  2000
  1829. C------ *DK
  1830. 2300  CDFLG = 0
  1831.       CFFL   = FULFLG
  1832.       IF( SYMTB(4,DIRNUM) .LT. 0 )  CFFL = CFFL + 1
  1833.       GOTO  2000
  1834. C------ *CD
  1835. 2400  CDFLG = DIRNUM
  1836.       SYMTB(5,CDFLG) = NMSTOR + 1
  1837.       SYMTB(6,CDFLG) = 0
  1838.       GOTO  2000
  1839. C------ *WEOF
  1840. 2500  ENDFILE  COMPIL
  1841.       GOTO  2000
  1842. C------ END OF (PLIN)
  1843. 9000  ENDFILE  COMPIL
  1844.       REWIND  PLIN
  1845.       REWIND  COMPIL
  1846.       ENDFILE  PLIN
  1847.       REWIND  PLIN
  1848.       IF( NPLFLG .NE. 0 )  ENDFILE  NEWPL
  1849.       IF( NPLFLG .NE. 0 )  REWIND   NEWPL
  1850.       IF( ERRFLG .EQ. 0 )  GOTO  9900
  1851.           ENDFILE  COMPIL
  1852.           REWIND   COMPIL
  1853.           IF( NPLFLG .EQ. 0 )  GOTO  9900
  1854.               ENDFILE  NEWPL
  1855.               REWIND   NEWPL
  1856. 9900  RETURN
  1857.       END
  1858.       SUBROUTINE  WTPL ( LFN )
  1859. C-
  1860. C--- WRITE ONE PL LINE TO LFN,  IF LFN=0 WRITE INTO MEM ARRAY
  1861. C-
  1862.       IMPLICIT INTEGER (A-Z)
  1863. C---
  1864.       COMMON /CHARS/  STAR, BLNK, COMA, PERD, SLAS
  1865.       COMMON /REC/    CALFLG, TYP, DIRNUM, SEQ, CARD4(20)
  1866.      1              , CARD4S(20)
  1867.           DIMENSION  REC(22)
  1868.               EQUIVALENCE  (DIRNUM, REC(1))
  1869. C---
  1870. 1004  FORMAT( I2,I4,I5 )
  1871. 1005  FORMAT( I2,I4,I5,/,4X,I4 )
  1872. 1009  FORMAT( I2,I4,I5,1X,20A4 )
  1873. C---
  1874.       IF( LFN .EQ. 0 )  GOTO  300
  1875.           IF( CALFLG .EQ. 0 )  GOTO  200
  1876.               WRITE( LFN, 1005 ) TYP, DIRNUM, SEQ, CALFLG
  1877.               GOTO  900
  1878. 200       IF( IABS( TYP ) .NE. 1 )  GOTO  220
  1879.               DO  202  I = 1 , 20
  1880.               I2 = 23 - I
  1881.               IF( REC(I2) .NE. BLNK )  GOTO  204
  1882. 202           CONTINUE
  1883. 204       WRITE( LFN, 1009 )  TYP, ( REC(I), I=1,I2 )
  1884.               GOTO  900
  1885. 220       WRITE( LFN, 1004 ) TYP, DIRNUM, SEQ
  1886.               GOTO  900
  1887. 300    CALL  MEMSTO
  1888. 900   RETURN
  1889.       END
  1890.